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(left, right)
2340                  : sv_cmp(left, right));
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(left, right)));
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(left, right)));
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(left, right)
2376                  : sv_cmp(left, right));
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         if (PL_op->op_private & HINT_INTEGER) {
2390           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2391           SETi(i);
2392         }
2393         else {
2394           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2395           SETu(u);
2396         }
2397       }
2398       else {
2399         do_vop(PL_op->op_type, TARG, left, right);
2400         SETTARG;
2401       }
2402       RETURN;
2403     }
2404 }
2405
2406 PP(pp_bit_or)
2407 {
2408     dVAR; dSP; dATARGET;
2409     const int op_type = PL_op->op_type;
2410
2411     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2412     {
2413       dPOPTOPssrl;
2414       if (SvNIOKp(left) || SvNIOKp(right)) {
2415         if (PL_op->op_private & HINT_INTEGER) {
2416           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2417           const IV r = SvIV_nomg(right);
2418           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2419           SETi(result);
2420         }
2421         else {
2422           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2423           const UV r = SvUV_nomg(right);
2424           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2425           SETu(result);
2426         }
2427       }
2428       else {
2429         do_vop(op_type, TARG, left, right);
2430         SETTARG;
2431       }
2432       RETURN;
2433     }
2434 }
2435
2436 PP(pp_negate)
2437 {
2438     dVAR; dSP; dTARGET;
2439     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2440     {
2441         SV * const sv = TOPs;
2442         const int flags = SvFLAGS(sv);
2443         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2444             /* It's publicly an integer, or privately an integer-not-float */
2445         oops_its_an_int:
2446             if (SvIsUV(sv)) {
2447                 if (SvIVX(sv) == IV_MIN) {
2448                     /* 2s complement assumption. */
2449                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2450                     RETURN;
2451                 }
2452                 else if (SvUVX(sv) <= IV_MAX) {
2453                     SETi(-SvIVX(sv));
2454                     RETURN;
2455                 }
2456             }
2457             else if (SvIVX(sv) != IV_MIN) {
2458                 SETi(-SvIVX(sv));
2459                 RETURN;
2460             }
2461 #ifdef PERL_PRESERVE_IVUV
2462             else {
2463                 SETu((UV)IV_MIN);
2464                 RETURN;
2465             }
2466 #endif
2467         }
2468         if (SvNIOKp(sv))
2469             SETn(-SvNV_nomg(sv));
2470         else if (SvPOKp(sv)) {
2471             STRLEN len;
2472             const char * const s = SvPV_nomg_const(sv, len);
2473             if (isIDFIRST(*s)) {
2474                 sv_setpvs(TARG, "-");
2475                 sv_catsv(TARG, sv);
2476             }
2477             else if (*s == '+' || *s == '-') {
2478                 sv_setsv_nomg(TARG, sv);
2479                 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2480             }
2481             else if (DO_UTF8(sv)) {
2482                 SvIV_please_nomg(sv);
2483                 if (SvIOK(sv))
2484                     goto oops_its_an_int;
2485                 if (SvNOK(sv))
2486                     sv_setnv(TARG, -SvNV_nomg(sv));
2487                 else {
2488                     sv_setpvs(TARG, "-");
2489                     sv_catsv(TARG, sv);
2490                 }
2491             }
2492             else {
2493                 SvIV_please_nomg(sv);
2494                 if (SvIOK(sv))
2495                   goto oops_its_an_int;
2496                 sv_setnv(TARG, -SvNV_nomg(sv));
2497             }
2498             SETTARG;
2499         }
2500         else
2501             SETn(-SvNV_nomg(sv));
2502     }
2503     RETURN;
2504 }
2505
2506 PP(pp_not)
2507 {
2508     dVAR; dSP;
2509     tryAMAGICun_MG(not_amg, AMGf_set);
2510     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2511     return NORMAL;
2512 }
2513
2514 PP(pp_complement)
2515 {
2516     dVAR; dSP; dTARGET;
2517     tryAMAGICun_MG(compl_amg, 0);
2518     {
2519       dTOPss;
2520       if (SvNIOKp(sv)) {
2521         if (PL_op->op_private & HINT_INTEGER) {
2522           const IV i = ~SvIV_nomg(sv);
2523           SETi(i);
2524         }
2525         else {
2526           const UV u = ~SvUV_nomg(sv);
2527           SETu(u);
2528         }
2529       }
2530       else {
2531         register U8 *tmps;
2532         register I32 anum;
2533         STRLEN len;
2534
2535         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2536         sv_setsv_nomg(TARG, sv);
2537         tmps = (U8*)SvPV_force_nomg(TARG, len);
2538         anum = len;
2539         if (SvUTF8(TARG)) {
2540           /* Calculate exact length, let's not estimate. */
2541           STRLEN targlen = 0;
2542           STRLEN l;
2543           UV nchar = 0;
2544           UV nwide = 0;
2545           U8 * const send = tmps + len;
2546           U8 * const origtmps = tmps;
2547           const UV utf8flags = UTF8_ALLOW_ANYUV;
2548
2549           while (tmps < send) {
2550             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2551             tmps += l;
2552             targlen += UNISKIP(~c);
2553             nchar++;
2554             if (c > 0xff)
2555                 nwide++;
2556           }
2557
2558           /* Now rewind strings and write them. */
2559           tmps = origtmps;
2560
2561           if (nwide) {
2562               U8 *result;
2563               U8 *p;
2564
2565               Newx(result, targlen + 1, U8);
2566               p = result;
2567               while (tmps < send) {
2568                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2569                   tmps += l;
2570                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2571               }
2572               *p = '\0';
2573               sv_usepvn_flags(TARG, (char*)result, targlen,
2574                               SV_HAS_TRAILING_NUL);
2575               SvUTF8_on(TARG);
2576           }
2577           else {
2578               U8 *result;
2579               U8 *p;
2580
2581               Newx(result, nchar + 1, U8);
2582               p = result;
2583               while (tmps < send) {
2584                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2585                   tmps += l;
2586                   *p++ = ~c;
2587               }
2588               *p = '\0';
2589               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2590               SvUTF8_off(TARG);
2591           }
2592           SETTARG;
2593           RETURN;
2594         }
2595 #ifdef LIBERAL
2596         {
2597             register long *tmpl;
2598             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2599                 *tmps = ~*tmps;
2600             tmpl = (long*)tmps;
2601             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2602                 *tmpl = ~*tmpl;
2603             tmps = (U8*)tmpl;
2604         }
2605 #endif
2606         for ( ; anum > 0; anum--, tmps++)
2607             *tmps = ~*tmps;
2608         SETTARG;
2609       }
2610       RETURN;
2611     }
2612 }
2613
2614 /* integer versions of some of the above */
2615
2616 PP(pp_i_multiply)
2617 {
2618     dVAR; dSP; dATARGET;
2619     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2620     {
2621       dPOPTOPiirl_nomg;
2622       SETi( left * right );
2623       RETURN;
2624     }
2625 }
2626
2627 PP(pp_i_divide)
2628 {
2629     IV num;
2630     dVAR; dSP; dATARGET;
2631     tryAMAGICbin_MG(div_amg, AMGf_assign);
2632     {
2633       dPOPTOPssrl;
2634       IV value = SvIV_nomg(right);
2635       if (value == 0)
2636           DIE(aTHX_ "Illegal division by zero");
2637       num = SvIV_nomg(left);
2638
2639       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2640       if (value == -1)
2641           value = - num;
2642       else
2643           value = num / value;
2644       SETi(value);
2645       RETURN;
2646     }
2647 }
2648
2649 #if defined(__GLIBC__) && IVSIZE == 8
2650 STATIC
2651 PP(pp_i_modulo_0)
2652 #else
2653 PP(pp_i_modulo)
2654 #endif
2655 {
2656      /* This is the vanilla old i_modulo. */
2657      dVAR; dSP; dATARGET;
2658      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2659      {
2660           dPOPTOPiirl_nomg;
2661           if (!right)
2662                DIE(aTHX_ "Illegal modulus zero");
2663           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2664           if (right == -1)
2665               SETi( 0 );
2666           else
2667               SETi( left % right );
2668           RETURN;
2669      }
2670 }
2671
2672 #if defined(__GLIBC__) && IVSIZE == 8
2673 STATIC
2674 PP(pp_i_modulo_1)
2675
2676 {
2677      /* This is the i_modulo with the workaround for the _moddi3 bug
2678       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2679       * See below for pp_i_modulo. */
2680      dVAR; dSP; dATARGET;
2681      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2682      {
2683           dPOPTOPiirl_nomg;
2684           if (!right)
2685                DIE(aTHX_ "Illegal modulus zero");
2686           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2687           if (right == -1)
2688               SETi( 0 );
2689           else
2690               SETi( left % PERL_ABS(right) );
2691           RETURN;
2692      }
2693 }
2694
2695 PP(pp_i_modulo)
2696 {
2697      dVAR; dSP; dATARGET;
2698      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2699      {
2700           dPOPTOPiirl_nomg;
2701           if (!right)
2702                DIE(aTHX_ "Illegal modulus zero");
2703           /* The assumption is to use hereafter the old vanilla version... */
2704           PL_op->op_ppaddr =
2705                PL_ppaddr[OP_I_MODULO] =
2706                    Perl_pp_i_modulo_0;
2707           /* .. but if we have glibc, we might have a buggy _moddi3
2708            * (at least glicb 2.2.5 is known to have this bug), in other
2709            * words our integer modulus with negative quad as the second
2710            * argument might be broken.  Test for this and re-patch the
2711            * opcode dispatch table if that is the case, remembering to
2712            * also apply the workaround so that this first round works
2713            * right, too.  See [perl #9402] for more information. */
2714           {
2715                IV l =   3;
2716                IV r = -10;
2717                /* Cannot do this check with inlined IV constants since
2718                 * that seems to work correctly even with the buggy glibc. */
2719                if (l % r == -3) {
2720                     /* Yikes, we have the bug.
2721                      * Patch in the workaround version. */
2722                     PL_op->op_ppaddr =
2723                          PL_ppaddr[OP_I_MODULO] =
2724                              &Perl_pp_i_modulo_1;
2725                     /* Make certain we work right this time, too. */
2726                     right = PERL_ABS(right);
2727                }
2728           }
2729           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2730           if (right == -1)
2731               SETi( 0 );
2732           else
2733               SETi( left % right );
2734           RETURN;
2735      }
2736 }
2737 #endif
2738
2739 PP(pp_i_add)
2740 {
2741     dVAR; dSP; dATARGET;
2742     tryAMAGICbin_MG(add_amg, AMGf_assign);
2743     {
2744       dPOPTOPiirl_ul_nomg;
2745       SETi( left + right );
2746       RETURN;
2747     }
2748 }
2749
2750 PP(pp_i_subtract)
2751 {
2752     dVAR; dSP; dATARGET;
2753     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2754     {
2755       dPOPTOPiirl_ul_nomg;
2756       SETi( left - right );
2757       RETURN;
2758     }
2759 }
2760
2761 PP(pp_i_lt)
2762 {
2763     dVAR; dSP;
2764     tryAMAGICbin_MG(lt_amg, AMGf_set);
2765     {
2766       dPOPTOPiirl_nomg;
2767       SETs(boolSV(left < right));
2768       RETURN;
2769     }
2770 }
2771
2772 PP(pp_i_gt)
2773 {
2774     dVAR; dSP;
2775     tryAMAGICbin_MG(gt_amg, AMGf_set);
2776     {
2777       dPOPTOPiirl_nomg;
2778       SETs(boolSV(left > right));
2779       RETURN;
2780     }
2781 }
2782
2783 PP(pp_i_le)
2784 {
2785     dVAR; dSP;
2786     tryAMAGICbin_MG(le_amg, AMGf_set);
2787     {
2788       dPOPTOPiirl_nomg;
2789       SETs(boolSV(left <= right));
2790       RETURN;
2791     }
2792 }
2793
2794 PP(pp_i_ge)
2795 {
2796     dVAR; dSP;
2797     tryAMAGICbin_MG(ge_amg, AMGf_set);
2798     {
2799       dPOPTOPiirl_nomg;
2800       SETs(boolSV(left >= right));
2801       RETURN;
2802     }
2803 }
2804
2805 PP(pp_i_eq)
2806 {
2807     dVAR; dSP;
2808     tryAMAGICbin_MG(eq_amg, AMGf_set);
2809     {
2810       dPOPTOPiirl_nomg;
2811       SETs(boolSV(left == right));
2812       RETURN;
2813     }
2814 }
2815
2816 PP(pp_i_ne)
2817 {
2818     dVAR; dSP;
2819     tryAMAGICbin_MG(ne_amg, AMGf_set);
2820     {
2821       dPOPTOPiirl_nomg;
2822       SETs(boolSV(left != right));
2823       RETURN;
2824     }
2825 }
2826
2827 PP(pp_i_ncmp)
2828 {
2829     dVAR; dSP; dTARGET;
2830     tryAMAGICbin_MG(ncmp_amg, 0);
2831     {
2832       dPOPTOPiirl_nomg;
2833       I32 value;
2834
2835       if (left > right)
2836         value = 1;
2837       else if (left < right)
2838         value = -1;
2839       else
2840         value = 0;
2841       SETi(value);
2842       RETURN;
2843     }
2844 }
2845
2846 PP(pp_i_negate)
2847 {
2848     dVAR; dSP; dTARGET;
2849     tryAMAGICun_MG(neg_amg, 0);
2850     {
2851         SV * const sv = TOPs;
2852         IV const i = SvIV_nomg(sv);
2853         SETi(-i);
2854         RETURN;
2855     }
2856 }
2857
2858 /* High falutin' math. */
2859
2860 PP(pp_atan2)
2861 {
2862     dVAR; dSP; dTARGET;
2863     tryAMAGICbin_MG(atan2_amg, 0);
2864     {
2865       dPOPTOPnnrl_nomg;
2866       SETn(Perl_atan2(left, right));
2867       RETURN;
2868     }
2869 }
2870
2871 PP(pp_sin)
2872 {
2873     dVAR; dSP; dTARGET;
2874     int amg_type = sin_amg;
2875     const char *neg_report = NULL;
2876     NV (*func)(NV) = Perl_sin;
2877     const int op_type = PL_op->op_type;
2878
2879     switch (op_type) {
2880     case OP_COS:
2881         amg_type = cos_amg;
2882         func = Perl_cos;
2883         break;
2884     case OP_EXP:
2885         amg_type = exp_amg;
2886         func = Perl_exp;
2887         break;
2888     case OP_LOG:
2889         amg_type = log_amg;
2890         func = Perl_log;
2891         neg_report = "log";
2892         break;
2893     case OP_SQRT:
2894         amg_type = sqrt_amg;
2895         func = Perl_sqrt;
2896         neg_report = "sqrt";
2897         break;
2898     }
2899
2900
2901     tryAMAGICun_MG(amg_type, 0);
2902     {
2903       SV * const arg = POPs;
2904       const NV value = SvNV_nomg(arg);
2905       if (neg_report) {
2906           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2907               SET_NUMERIC_STANDARD();
2908               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2909           }
2910       }
2911       XPUSHn(func(value));
2912       RETURN;
2913     }
2914 }
2915
2916 /* Support Configure command-line overrides for rand() functions.
2917    After 5.005, perhaps we should replace this by Configure support
2918    for drand48(), random(), or rand().  For 5.005, though, maintain
2919    compatibility by calling rand() but allow the user to override it.
2920    See INSTALL for details.  --Andy Dougherty  15 July 1998
2921 */
2922 /* Now it's after 5.005, and Configure supports drand48() and random(),
2923    in addition to rand().  So the overrides should not be needed any more.
2924    --Jarkko Hietaniemi  27 September 1998
2925  */
2926
2927 #ifndef HAS_DRAND48_PROTO
2928 extern double drand48 (void);
2929 #endif
2930
2931 PP(pp_rand)
2932 {
2933     dVAR; dSP; dTARGET;
2934     NV value;
2935     if (MAXARG < 1)
2936         value = 1.0;
2937     else
2938         value = POPn;
2939     if (value == 0.0)
2940         value = 1.0;
2941     if (!PL_srand_called) {
2942         (void)seedDrand01((Rand_seed_t)seed());
2943         PL_srand_called = TRUE;
2944     }
2945     value *= Drand01();
2946     XPUSHn(value);
2947     RETURN;
2948 }
2949
2950 PP(pp_srand)
2951 {
2952     dVAR; dSP; dTARGET;
2953     const UV anum = (MAXARG < 1) ? seed() : POPu;
2954     (void)seedDrand01((Rand_seed_t)anum);
2955     PL_srand_called = TRUE;
2956     if (anum)
2957         XPUSHu(anum);
2958     else {
2959         /* Historically srand always returned true. We can avoid breaking
2960            that like this:  */
2961         sv_setpvs(TARG, "0 but true");
2962         XPUSHTARG;
2963     }
2964     RETURN;
2965 }
2966
2967 PP(pp_int)
2968 {
2969     dVAR; dSP; dTARGET;
2970     tryAMAGICun_MG(int_amg, AMGf_numeric);
2971     {
2972       SV * const sv = TOPs;
2973       const IV iv = SvIV_nomg(sv);
2974       /* XXX it's arguable that compiler casting to IV might be subtly
2975          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2976          else preferring IV has introduced a subtle behaviour change bug. OTOH
2977          relying on floating point to be accurate is a bug.  */
2978
2979       if (!SvOK(sv)) {
2980         SETu(0);
2981       }
2982       else if (SvIOK(sv)) {
2983         if (SvIsUV(sv))
2984             SETu(SvUV_nomg(sv));
2985         else
2986             SETi(iv);
2987       }
2988       else {
2989           const NV value = SvNV_nomg(sv);
2990           if (value >= 0.0) {
2991               if (value < (NV)UV_MAX + 0.5) {
2992                   SETu(U_V(value));
2993               } else {
2994                   SETn(Perl_floor(value));
2995               }
2996           }
2997           else {
2998               if (value > (NV)IV_MIN - 0.5) {
2999                   SETi(I_V(value));
3000               } else {
3001                   SETn(Perl_ceil(value));
3002               }
3003           }
3004       }
3005     }
3006     RETURN;
3007 }
3008
3009 PP(pp_abs)
3010 {
3011     dVAR; dSP; dTARGET;
3012     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3013     {
3014       SV * const sv = TOPs;
3015       /* This will cache the NV value if string isn't actually integer  */
3016       const IV iv = SvIV_nomg(sv);
3017
3018       if (!SvOK(sv)) {
3019         SETu(0);
3020       }
3021       else if (SvIOK(sv)) {
3022         /* IVX is precise  */
3023         if (SvIsUV(sv)) {
3024           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3025         } else {
3026           if (iv >= 0) {
3027             SETi(iv);
3028           } else {
3029             if (iv != IV_MIN) {
3030               SETi(-iv);
3031             } else {
3032               /* 2s complement assumption. Also, not really needed as
3033                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3034               SETu(IV_MIN);
3035             }
3036           }
3037         }
3038       } else{
3039         const NV value = SvNV_nomg(sv);
3040         if (value < 0.0)
3041           SETn(-value);
3042         else
3043           SETn(value);
3044       }
3045     }
3046     RETURN;
3047 }
3048
3049 PP(pp_oct)
3050 {
3051     dVAR; dSP; dTARGET;
3052     const char *tmps;
3053     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3054     STRLEN len;
3055     NV result_nv;
3056     UV result_uv;
3057     SV* const sv = POPs;
3058
3059     tmps = (SvPV_const(sv, len));
3060     if (DO_UTF8(sv)) {
3061          /* If Unicode, try to downgrade
3062           * If not possible, croak. */
3063          SV* const tsv = sv_2mortal(newSVsv(sv));
3064
3065          SvUTF8_on(tsv);
3066          sv_utf8_downgrade(tsv, FALSE);
3067          tmps = SvPV_const(tsv, len);
3068     }
3069     if (PL_op->op_type == OP_HEX)
3070         goto hex;
3071
3072     while (*tmps && len && isSPACE(*tmps))
3073         tmps++, len--;
3074     if (*tmps == '0')
3075         tmps++, len--;
3076     if (*tmps == 'x' || *tmps == 'X') {
3077     hex:
3078         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3079     }
3080     else if (*tmps == 'b' || *tmps == 'B')
3081         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3082     else
3083         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3084
3085     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3086         XPUSHn(result_nv);
3087     }
3088     else {
3089         XPUSHu(result_uv);
3090     }
3091     RETURN;
3092 }
3093
3094 /* String stuff. */
3095
3096 PP(pp_length)
3097 {
3098     dVAR; dSP; dTARGET;
3099     SV * const sv = TOPs;
3100
3101     if (SvGAMAGIC(sv)) {
3102         /* For an overloaded or magic scalar, we can't know in advance if
3103            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3104            it likes to cache the length. Maybe that should be a documented
3105            feature of it.
3106         */
3107         STRLEN len;
3108         const char *const p
3109             = sv_2pv_flags(sv, &len,
3110                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3111
3112         if (!p) {
3113             sv_setsv(TARG, &PL_sv_undef);
3114             SETTARG;
3115         }
3116         else if (DO_UTF8(sv)) {
3117             SETi(utf8_length((U8*)p, (U8*)p + len));
3118         }
3119         else
3120             SETi(len);
3121     } else if (SvOK(sv)) {
3122         /* Neither magic nor overloaded.  */
3123         if (DO_UTF8(sv))
3124             SETi(sv_len_utf8(sv));
3125         else
3126             SETi(sv_len(sv));
3127     } else {
3128         sv_setsv_nomg(TARG, &PL_sv_undef);
3129         SETTARG;
3130     }
3131     RETURN;
3132 }
3133
3134 PP(pp_substr)
3135 {
3136     dVAR; dSP; dTARGET;
3137     SV *sv;
3138     STRLEN curlen;
3139     STRLEN utf8_curlen;
3140     SV *   pos_sv;
3141     IV     pos1_iv;
3142     int    pos1_is_uv;
3143     IV     pos2_iv;
3144     int    pos2_is_uv;
3145     SV *   len_sv;
3146     IV     len_iv = 0;
3147     int    len_is_uv = 1;
3148     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3149     const char *tmps;
3150     const IV arybase = CopARYBASE_get(PL_curcop);
3151     SV *repl_sv = NULL;
3152     const char *repl = NULL;
3153     STRLEN repl_len;
3154     const int num_args = PL_op->op_private & 7;
3155     bool repl_need_utf8_upgrade = FALSE;
3156     bool repl_is_utf8 = FALSE;
3157
3158     if (num_args > 2) {
3159         if (num_args > 3) {
3160             repl_sv = POPs;
3161             repl = SvPV_const(repl_sv, repl_len);
3162             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3163         }
3164         len_sv    = POPs;
3165         len_iv    = SvIV(len_sv);
3166         len_is_uv = SvIOK_UV(len_sv);
3167     }
3168     pos_sv     = POPs;
3169     pos1_iv    = SvIV(pos_sv);
3170     pos1_is_uv = SvIOK_UV(pos_sv);
3171     sv = POPs;
3172     PUTBACK;
3173     if (repl_sv) {
3174         if (repl_is_utf8) {
3175             if (!DO_UTF8(sv))
3176                 sv_utf8_upgrade(sv);
3177         }
3178         else if (DO_UTF8(sv))
3179             repl_need_utf8_upgrade = TRUE;
3180     }
3181     tmps = SvPV_const(sv, curlen);
3182     if (DO_UTF8(sv)) {
3183         utf8_curlen = sv_len_utf8(sv);
3184         if (utf8_curlen == curlen)
3185             utf8_curlen = 0;
3186         else
3187             curlen = utf8_curlen;
3188     }
3189     else
3190         utf8_curlen = 0;
3191
3192     if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3193         UV pos1_uv = pos1_iv-arybase;
3194         /* Overflow can occur when $[ < 0 */
3195         if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3196             goto bound_fail;
3197         pos1_iv = pos1_uv;
3198         pos1_is_uv = 1;
3199     }
3200     else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3201         goto bound_fail;  /* $[=3; substr($_,2,...) */
3202     }
3203     else { /* pos < $[ */
3204         if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3205             pos1_iv = curlen;
3206             pos1_is_uv = 1;
3207         } else {
3208             if (curlen) {
3209                 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3210                 pos1_iv += curlen;
3211            }
3212         }
3213     }
3214     if (pos1_is_uv || pos1_iv > 0) {
3215         if ((UV)pos1_iv > curlen)
3216             goto bound_fail;
3217     }
3218
3219     if (num_args > 2) {
3220         if (!len_is_uv && len_iv < 0) {
3221             pos2_iv = curlen + len_iv;
3222             if (curlen)
3223                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3224             else
3225                 pos2_is_uv = 0;
3226         } else {  /* len_iv >= 0 */
3227             if (!pos1_is_uv && pos1_iv < 0) {
3228                 pos2_iv = pos1_iv + len_iv;
3229                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3230             } else {
3231                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3232                     pos2_iv = curlen;
3233                 else
3234                     pos2_iv = pos1_iv+len_iv;
3235                 pos2_is_uv = 1;
3236             }
3237         }
3238     }
3239     else {
3240         pos2_iv = curlen;
3241         pos2_is_uv = 1;
3242     }
3243
3244     if (!pos2_is_uv && pos2_iv < 0) {
3245         if (!pos1_is_uv && pos1_iv < 0)
3246             goto bound_fail;
3247         pos2_iv = 0;
3248     }
3249     else if (!pos1_is_uv && pos1_iv < 0)
3250         pos1_iv = 0;
3251
3252     if ((UV)pos2_iv < (UV)pos1_iv)
3253         pos2_iv = pos1_iv;
3254     if ((UV)pos2_iv > curlen)
3255         pos2_iv = curlen;
3256
3257     {
3258         /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3259         const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3260         const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3261         STRLEN byte_len = len;
3262         STRLEN byte_pos = utf8_curlen
3263             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3264
3265         if (lvalue && !repl) {
3266             SV * ret;
3267
3268             if (!SvGMAGICAL(sv)) {
3269                 if (SvROK(sv)) {
3270                     SvPV_force_nolen(sv);
3271                     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3272                                    "Attempt to use reference as lvalue in substr");
3273                 }
3274                 if (isGV_with_GP(sv))
3275                     SvPV_force_nolen(sv);
3276                 else if (SvOK(sv))      /* is it defined ? */
3277                     (void)SvPOK_only_UTF8(sv);
3278                 else
3279                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3280             }
3281
3282             ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3283             sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3284             LvTYPE(ret) = 'x';
3285             LvTARG(ret) = SvREFCNT_inc_simple(sv);
3286             LvTARGOFF(ret) = pos;
3287             LvTARGLEN(ret) = len;
3288
3289             SPAGAIN;
3290             PUSHs(ret);    /* avoid SvSETMAGIC here */
3291             RETURN;
3292         }
3293
3294         SvTAINTED_off(TARG);                    /* decontaminate */
3295         SvUTF8_off(TARG);                       /* decontaminate */
3296
3297         tmps += byte_pos;
3298         sv_setpvn(TARG, tmps, byte_len);
3299 #ifdef USE_LOCALE_COLLATE
3300         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3301 #endif
3302         if (utf8_curlen)
3303             SvUTF8_on(TARG);
3304
3305         if (repl) {
3306             SV* repl_sv_copy = NULL;
3307
3308             if (repl_need_utf8_upgrade) {
3309                 repl_sv_copy = newSVsv(repl_sv);
3310                 sv_utf8_upgrade(repl_sv_copy);
3311                 repl = SvPV_const(repl_sv_copy, repl_len);
3312                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3313             }
3314             if (!SvOK(sv))
3315                 sv_setpvs(sv, "");
3316             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3317             if (repl_is_utf8)
3318                 SvUTF8_on(sv);
3319             SvREFCNT_dec(repl_sv_copy);
3320         }
3321     }
3322     SPAGAIN;
3323     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3324     RETURN;
3325
3326 bound_fail:
3327     if (lvalue || repl)
3328         Perl_croak(aTHX_ "substr outside of string");
3329     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3330     RETPUSHUNDEF;
3331 }
3332
3333 PP(pp_vec)
3334 {
3335     dVAR; dSP;
3336     register const IV size   = POPi;
3337     register const IV offset = POPi;
3338     register SV * const src = POPs;
3339     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3340     SV * ret;
3341
3342     if (lvalue) {                       /* it's an lvalue! */
3343         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3344         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3345         LvTYPE(ret) = 'v';
3346         LvTARG(ret) = SvREFCNT_inc_simple(src);
3347         LvTARGOFF(ret) = offset;
3348         LvTARGLEN(ret) = size;
3349     }
3350     else {
3351         dTARGET;
3352         SvTAINTED_off(TARG);            /* decontaminate */
3353         ret = TARG;
3354     }
3355
3356     sv_setuv(ret, do_vecget(src, offset, size));
3357     PUSHs(ret);
3358     RETURN;
3359 }
3360
3361 PP(pp_index)
3362 {
3363     dVAR; dSP; dTARGET;
3364     SV *big;
3365     SV *little;
3366     SV *temp = NULL;
3367     STRLEN biglen;
3368     STRLEN llen = 0;
3369     I32 offset;
3370     I32 retval;
3371     const char *big_p;
3372     const char *little_p;
3373     const I32 arybase = CopARYBASE_get(PL_curcop);
3374     bool big_utf8;
3375     bool little_utf8;
3376     const bool is_index = PL_op->op_type == OP_INDEX;
3377
3378     if (MAXARG >= 3) {
3379         /* arybase is in characters, like offset, so combine prior to the
3380            UTF-8 to bytes calculation.  */
3381         offset = POPi - arybase;
3382     }
3383     little = POPs;
3384     big = POPs;
3385     big_p = SvPV_const(big, biglen);
3386     little_p = SvPV_const(little, llen);
3387
3388     big_utf8 = DO_UTF8(big);
3389     little_utf8 = DO_UTF8(little);
3390     if (big_utf8 ^ little_utf8) {
3391         /* One needs to be upgraded.  */
3392         if (little_utf8 && !PL_encoding) {
3393             /* Well, maybe instead we might be able to downgrade the small
3394                string?  */
3395             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3396                                                      &little_utf8);
3397             if (little_utf8) {
3398                 /* If the large string is ISO-8859-1, and it's not possible to
3399                    convert the small string to ISO-8859-1, then there is no
3400                    way that it could be found anywhere by index.  */
3401                 retval = -1;
3402                 goto fail;
3403             }
3404
3405             /* At this point, pv is a malloc()ed string. So donate it to temp
3406                to ensure it will get free()d  */
3407             little = temp = newSV(0);
3408             sv_usepvn(temp, pv, llen);
3409             little_p = SvPVX(little);
3410         } else {
3411             temp = little_utf8
3412                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3413
3414             if (PL_encoding) {
3415                 sv_recode_to_utf8(temp, PL_encoding);
3416             } else {
3417                 sv_utf8_upgrade(temp);
3418             }
3419             if (little_utf8) {
3420                 big = temp;
3421                 big_utf8 = TRUE;
3422                 big_p = SvPV_const(big, biglen);
3423             } else {
3424                 little = temp;
3425                 little_p = SvPV_const(little, llen);
3426             }
3427         }
3428     }
3429     if (SvGAMAGIC(big)) {
3430         /* Life just becomes a lot easier if I use a temporary here.
3431            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3432            will trigger magic and overloading again, as will fbm_instr()
3433         */
3434         big = newSVpvn_flags(big_p, biglen,
3435                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3436         big_p = SvPVX(big);
3437     }
3438     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3439         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3440            warn on undef, and we've already triggered a warning with the
3441            SvPV_const some lines above. We can't remove that, as we need to
3442            call some SvPV to trigger overloading early and find out if the
3443            string is UTF-8.
3444            This is all getting to messy. The API isn't quite clean enough,
3445            because data access has side effects.
3446         */
3447         little = newSVpvn_flags(little_p, llen,
3448                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3449         little_p = SvPVX(little);
3450     }
3451
3452     if (MAXARG < 3)
3453         offset = is_index ? 0 : biglen;
3454     else {
3455         if (big_utf8 && offset > 0)
3456             sv_pos_u2b(big, &offset, 0);
3457         if (!is_index)
3458             offset += llen;
3459     }
3460     if (offset < 0)
3461         offset = 0;
3462     else if (offset > (I32)biglen)
3463         offset = biglen;
3464     if (!(little_p = is_index
3465           ? fbm_instr((unsigned char*)big_p + offset,
3466                       (unsigned char*)big_p + biglen, little, 0)
3467           : rninstr(big_p,  big_p  + offset,
3468                     little_p, little_p + llen)))
3469         retval = -1;
3470     else {
3471         retval = little_p - big_p;
3472         if (retval > 0 && big_utf8)
3473             sv_pos_b2u(big, &retval);
3474     }
3475     SvREFCNT_dec(temp);
3476  fail:
3477     PUSHi(retval + arybase);
3478     RETURN;
3479 }
3480
3481 PP(pp_sprintf)
3482 {
3483     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3484     if (SvTAINTED(MARK[1]))
3485         TAINT_PROPER("sprintf");
3486     SvTAINTED_off(TARG);
3487     do_sprintf(TARG, SP-MARK, MARK+1);
3488     TAINT_IF(SvTAINTED(TARG));
3489     SP = ORIGMARK;
3490     PUSHTARG;
3491     RETURN;
3492 }
3493
3494 PP(pp_ord)
3495 {
3496     dVAR; dSP; dTARGET;
3497
3498     SV *argsv = POPs;
3499     STRLEN len;
3500     const U8 *s = (U8*)SvPV_const(argsv, len);
3501
3502     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3503         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3504         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3505         argsv = tmpsv;
3506     }
3507
3508     XPUSHu(DO_UTF8(argsv) ?
3509            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3510            (UV)(*s & 0xff));
3511
3512     RETURN;
3513 }
3514
3515 PP(pp_chr)
3516 {
3517     dVAR; dSP; dTARGET;
3518     char *tmps;
3519     UV value;
3520
3521     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3522          ||
3523          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3524         if (IN_BYTES) {
3525             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3526         } else {
3527             (void) POPs; /* Ignore the argument value. */
3528             value = UNICODE_REPLACEMENT;
3529         }
3530     } else {
3531         value = POPu;
3532     }
3533
3534     SvUPGRADE(TARG,SVt_PV);
3535
3536     if (value > 255 && !IN_BYTES) {
3537         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3538         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3539         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3540         *tmps = '\0';
3541         (void)SvPOK_only(TARG);
3542         SvUTF8_on(TARG);
3543         XPUSHs(TARG);
3544         RETURN;
3545     }
3546
3547     SvGROW(TARG,2);
3548     SvCUR_set(TARG, 1);
3549     tmps = SvPVX(TARG);
3550     *tmps++ = (char)value;
3551     *tmps = '\0';
3552     (void)SvPOK_only(TARG);
3553
3554     if (PL_encoding && !IN_BYTES) {
3555         sv_recode_to_utf8(TARG, PL_encoding);
3556         tmps = SvPVX(TARG);
3557         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3558             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3559             SvGROW(TARG, 2);
3560             tmps = SvPVX(TARG);
3561             SvCUR_set(TARG, 1);
3562             *tmps++ = (char)value;
3563             *tmps = '\0';
3564             SvUTF8_off(TARG);
3565         }
3566     }
3567
3568     XPUSHs(TARG);
3569     RETURN;
3570 }
3571
3572 PP(pp_crypt)
3573 {
3574 #ifdef HAS_CRYPT
3575     dVAR; dSP; dTARGET;
3576     dPOPTOPssrl;
3577     STRLEN len;
3578     const char *tmps = SvPV_const(left, len);
3579
3580     if (DO_UTF8(left)) {
3581          /* If Unicode, try to downgrade.
3582           * If not possible, croak.
3583           * Yes, we made this up.  */
3584          SV* const tsv = sv_2mortal(newSVsv(left));
3585
3586          SvUTF8_on(tsv);
3587          sv_utf8_downgrade(tsv, FALSE);
3588          tmps = SvPV_const(tsv, len);
3589     }
3590 #   ifdef USE_ITHREADS
3591 #     ifdef HAS_CRYPT_R
3592     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3593       /* This should be threadsafe because in ithreads there is only
3594        * one thread per interpreter.  If this would not be true,
3595        * we would need a mutex to protect this malloc. */
3596         PL_reentrant_buffer->_crypt_struct_buffer =
3597           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3598 #if defined(__GLIBC__) || defined(__EMX__)
3599         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3600             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3601             /* work around glibc-2.2.5 bug */
3602             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3603         }
3604 #endif
3605     }
3606 #     endif /* HAS_CRYPT_R */
3607 #   endif /* USE_ITHREADS */
3608 #   ifdef FCRYPT
3609     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3610 #   else
3611     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3612 #   endif
3613     SETTARG;
3614     RETURN;
3615 #else
3616     DIE(aTHX_
3617       "The crypt() function is unimplemented due to excessive paranoia.");
3618 #endif
3619 }
3620
3621 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3622  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3623
3624 /* Both the characters below can be stored in two UTF-8 bytes.  In UTF-8 the max
3625  * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3626  * See http://www.unicode.org/unicode/reports/tr16 */
3627 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178    /* Also is title case */
3628 #define GREEK_CAPITAL_LETTER_MU 0x039C  /* Upper and title case of MICRON */
3629
3630 /* Below are several macros that generate code */
3631 /* Generates code to store a unicode codepoint c that is known to occupy
3632  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3633 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c)                                    \
3634     STMT_START {                                                            \
3635         *(p) = UTF8_TWO_BYTE_HI(c);                                         \
3636         *((p)+1) = UTF8_TWO_BYTE_LO(c);                                     \
3637     } STMT_END
3638
3639 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3640  * available byte after the two bytes */
3641 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3642     STMT_START {                                                            \
3643         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3644         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3645     } STMT_END
3646
3647 /* Generates code to store the upper case of latin1 character l which is known
3648  * to have its upper case be non-latin1 into the two bytes p and p+1.  There
3649  * are only two characters that fit this description, and this macro knows
3650  * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3651  * bytes */
3652 #define STORE_NON_LATIN1_UC(p, l)                                           \
3653 STMT_START {                                                                \
3654     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3655         STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);  \
3656     } else { /* Must be the following letter */                                                             \
3657         STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);           \
3658     }                                                                       \
3659 } STMT_END
3660
3661 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3662  * after the character stored */
3663 #define CAT_NON_LATIN1_UC(p, l)                                             \
3664 STMT_START {                                                                \
3665     if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3666         CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);    \
3667     } else {                                                                \
3668         CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU);             \
3669     }                                                                       \
3670 } STMT_END
3671
3672 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3673  * case of l into p and p+1.  u must be the result of toUPPER_LATIN1_MOD(l),
3674  * and must require two bytes to store it.  Advances p to point to the next
3675  * available position */
3676 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u)                                 \
3677 STMT_START {                                                                \
3678     if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {                       \
3679         CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3680     } else if (l == LATIN_SMALL_LETTER_SHARP_S) {                           \
3681         *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */                \
3682     } else {/* else is one of the other two special cases */                \
3683         CAT_NON_LATIN1_UC((p), (l));                                        \
3684     }                                                                       \
3685 } STMT_END
3686
3687 PP(pp_ucfirst)
3688 {
3689     /* Actually is both lcfirst() and ucfirst().  Only the first character
3690      * changes.  This means that possibly we can change in-place, ie., just
3691      * take the source and change that one character and store it back, but not
3692      * if read-only etc, or if the length changes */
3693
3694     dVAR;
3695     dSP;
3696     SV *source = TOPs;
3697     STRLEN slen; /* slen is the byte length of the whole SV. */
3698     STRLEN need;
3699     SV *dest;
3700     bool inplace;   /* ? Convert first char only, in-place */
3701     bool doing_utf8 = FALSE;               /* ? using utf8 */
3702     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3703     const int op_type = PL_op->op_type;
3704     const U8 *s;
3705     U8 *d;
3706     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3707     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3708                      * stored as UTF-8 at s. */
3709     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3710                      * lowercased) character stored in tmpbuf.  May be either
3711                      * UTF-8 or not, but in either case is the number of bytes */
3712
3713     SvGETMAGIC(source);
3714     if (SvOK(source)) {
3715         s = (const U8*)SvPV_nomg_const(source, slen);
3716     } else {
3717         if (ckWARN(WARN_UNINITIALIZED))
3718             report_uninit(source);
3719         s = (const U8*)"";
3720         slen = 0;
3721     }
3722
3723     /* We may be able to get away with changing only the first character, in
3724      * place, but not if read-only, etc.  Later we may discover more reasons to
3725      * not convert in-place. */
3726     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3727
3728     /* First calculate what the changed first character should be.  This affects
3729      * whether we can just swap it out, leaving the rest of the string unchanged,
3730      * or even if have to convert the dest to UTF-8 when the source isn't */
3731
3732     if (! slen) {   /* If empty */
3733         need = 1; /* still need a trailing NUL */
3734     }
3735     else if (DO_UTF8(source)) { /* Is the source utf8? */
3736         doing_utf8 = TRUE;
3737
3738 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3739  * and doesn't allow for the user to specify their own.  When code is added to
3740  * detect if there is a user-defined mapping in force here, and if so to use
3741  * that, then the code below can be compiled.  The detection would be a good
3742  * thing anyway, as currently the user-defined mappings only work on utf8
3743  * strings, and thus depend on the chosen internal storage method, which is a
3744  * bad thing */
3745 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3746         if (UTF8_IS_INVARIANT(*s)) {
3747
3748             /* An invariant source character is either ASCII or, in EBCDIC, an
3749              * ASCII equivalent or a caseless C1 control.  In both these cases,
3750              * the lower and upper cases of any character are also invariants
3751              * (and title case is the same as upper case).  So it is safe to
3752              * use the simple case change macros which avoid the overhead of
3753              * the general functions.  Note that if perl were to be extended to
3754              * do locale handling in UTF-8 strings, this wouldn't be true in,
3755              * for example, Lithuanian or Turkic.  */
3756             *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3757             tculen = ulen = 1;
3758             need = slen + 1;
3759         }
3760         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3761             U8 chr;
3762
3763             /* Similarly, if the source character isn't invariant but is in the
3764              * latin1 range (or EBCDIC equivalent thereof), we have the case
3765              * changes compiled into perl, and can avoid the overhead of the
3766              * general functions.  In this range, the characters are stored as
3767              * two UTF-8 bytes, and it so happens that any changed-case version
3768              * is also two bytes (in both ASCIIish and EBCDIC machines). */
3769             tculen = ulen = 2;
3770             need = slen + 1;
3771
3772             /* Convert the two source bytes to a single Unicode code point
3773              * value, change case and save for below */
3774             chr = UTF8_ACCUMULATE(*s, *(s+1));
3775             if (op_type == OP_LCFIRST) {    /* lower casing is easy */
3776                 U8 lower = toLOWER_LATIN1(chr);
3777                 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3778             }
3779             else {      /* ucfirst */
3780                 U8 upper = toUPPER_LATIN1_MOD(chr);
3781
3782                 /* Most of the latin1 range characters are well-behaved.  Their
3783                  * title and upper cases are the same, and are also in the
3784                  * latin1 range.  The macro above returns their upper (hence
3785                  * title) case, and all that need be done is to save the result
3786                  * for below.  However, several characters are problematic, and
3787                  * have to be handled specially.  The MOD in the macro name
3788                  * above means that these tricky characters all get mapped to
3789                  * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3790                  * This mapping saves some tests for the majority of the
3791                  * characters */
3792
3793                 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3794
3795                     /* Not tricky.  Just save it. */
3796                     STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3797                 }
3798                 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3799
3800                     /* This one is tricky because it is two characters long,
3801                      * though the UTF-8 is still two bytes, so the stored
3802                      * length doesn't change */
3803                     *tmpbuf = 'S';  /* The UTF-8 is 'Ss' */
3804                     *(tmpbuf + 1) = 's';
3805                 }
3806                 else {
3807
3808                     /* The other two have their title and upper cases the same,
3809                      * but are tricky because the changed-case characters
3810                      * aren't in the latin1 range.  They, however, do fit into
3811                      * two UTF-8 bytes */
3812                     STORE_NON_LATIN1_UC(tmpbuf, chr);
3813                 }
3814             }
3815         }
3816         else {
3817 #endif  /* end of dont want to break user-defined casing */
3818
3819             /* Here, can't short-cut the general case */
3820
3821             utf8_to_uvchr(s, &ulen);
3822             if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3823             else toLOWER_utf8(s, tmpbuf, &tculen);
3824
3825             /* we can't do in-place if the length changes.  */
3826             if (ulen != tculen) inplace = FALSE;
3827             need = slen + 1 - ulen + tculen;
3828 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3829         }
3830 #endif
3831     }
3832     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3833             * latin1 is treated as caseless.  Note that a locale takes
3834             * precedence */
3835         tculen = 1;     /* Most characters will require one byte, but this will
3836                          * need to be overridden for the tricky ones */
3837         need = slen + 1;
3838
3839         if (op_type == OP_LCFIRST) {
3840
3841             /* lower case the first letter: no trickiness for any character */
3842             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3843                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3844         }
3845         /* is ucfirst() */
3846         else if (IN_LOCALE_RUNTIME) {
3847             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3848                                          * have upper and title case different
3849                                          */
3850         }
3851         else if (! IN_UNI_8_BIT) {
3852             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3853                                          * on EBCDIC machines whatever the
3854                                          * native function does */
3855         }
3856         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3857             *tmpbuf = toUPPER_LATIN1_MOD(*s);
3858
3859             /* tmpbuf now has the correct title case for all latin1 characters
3860              * except for the several ones that have tricky handling.  All
3861              * of these are mapped by the MOD to the letter below. */
3862             if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3863
3864                 /* The length is going to change, with all three of these, so
3865                  * can't replace just the first character */
3866                 inplace = FALSE;
3867
3868                 /* We use the original to distinguish between these tricky
3869                  * cases */
3870                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3871                     /* Two character title case 'Ss', but can remain non-UTF-8 */
3872                     need = slen + 2;
3873                     *tmpbuf = 'S';
3874                     *(tmpbuf + 1) = 's';   /* Assert: length(tmpbuf) >= 2 */
3875                     tculen = 2;
3876                 }
3877                 else {
3878
3879                     /* The other two tricky ones have their title case outside
3880                      * latin1.  It is the same as their upper case. */
3881                     doing_utf8 = TRUE;
3882                     STORE_NON_LATIN1_UC(tmpbuf, *s);
3883
3884                     /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3885                      * and their upper cases is 2. */
3886                     tculen = ulen = 2;
3887
3888                     /* The entire result will have to be in UTF-8.  Assume worst
3889                      * case sizing in conversion. (all latin1 characters occupy
3890                      * at most two bytes in utf8) */
3891                     convert_source_to_utf8 = TRUE;
3892                     need = slen * 2 + 1;
3893                 }
3894             } /* End of is one of the three special chars */
3895         } /* End of use Unicode (Latin1) semantics */
3896     } /* End of changing the case of the first character */
3897
3898     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3899      * generate the result */
3900     if (inplace) {
3901
3902         /* We can convert in place.  This means we change just the first
3903          * character without disturbing the rest; no need to grow */
3904         dest = source;
3905         s = d = (U8*)SvPV_force_nomg(source, slen);
3906     } else {
3907         dTARGET;
3908
3909         dest = TARG;
3910
3911         /* Here, we can't convert in place; we earlier calculated how much
3912          * space we will need, so grow to accommodate that */
3913         SvUPGRADE(dest, SVt_PV);
3914         d = (U8*)SvGROW(dest, need);
3915         (void)SvPOK_only(dest);
3916
3917         SETs(dest);
3918     }
3919
3920     if (doing_utf8) {
3921         if (! inplace) {
3922             if (! convert_source_to_utf8) {
3923
3924                 /* Here  both source and dest are in UTF-8, but have to create
3925                  * the entire output.  We initialize the result to be the
3926                  * title/lower cased first character, and then append the rest
3927                  * of the string. */
3928                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3929                 if (slen > ulen) {
3930                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3931                 }
3932             }
3933             else {
3934                 const U8 *const send = s + slen;
3935
3936                 /* Here the dest needs to be in UTF-8, but the source isn't,
3937                  * except we earlier UTF-8'd the first character of the source
3938                  * into tmpbuf.  First put that into dest, and then append the
3939                  * rest of the source, converting it to UTF-8 as we go. */
3940
3941                 /* Assert tculen is 2 here because the only two characters that
3942                  * get to this part of the code have 2-byte UTF-8 equivalents */
3943                 *d++ = *tmpbuf;
3944                 *d++ = *(tmpbuf + 1);
3945                 s++;    /* We have just processed the 1st char */
3946
3947                 for (; s < send; s++) {
3948                     d = uvchr_to_utf8(d, *s);
3949                 }
3950                 *d = '\0';
3951                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3952             }
3953             SvUTF8_on(dest);
3954         }
3955         else {   /* in-place UTF-8.  Just overwrite the first character */
3956             Copy(tmpbuf, d, tculen, U8);
3957             SvCUR_set(dest, need - 1);
3958         }
3959     }
3960     else {  /* Neither source nor dest are in or need to be UTF-8 */
3961         if (slen) {
3962             if (IN_LOCALE_RUNTIME) {
3963                 TAINT;
3964                 SvTAINTED_on(dest);
3965             }
3966             if (inplace) {  /* in-place, only need to change the 1st char */
3967                 *d = *tmpbuf;
3968             }
3969             else {      /* Not in-place */
3970
3971                 /* Copy the case-changed character(s) from tmpbuf */
3972                 Copy(tmpbuf, d, tculen, U8);
3973                 d += tculen - 1; /* Code below expects d to point to final
3974                                   * character stored */
3975             }
3976         }
3977         else {  /* empty source */
3978             /* See bug #39028: Don't taint if empty  */
3979             *d = *s;
3980         }
3981
3982         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3983          * the destination to retain that flag */
3984         if (SvUTF8(source))
3985             SvUTF8_on(dest);
3986
3987         if (!inplace) { /* Finish the rest of the string, unchanged */
3988             /* This will copy the trailing NUL  */
3989             Copy(s + 1, d + 1, slen, U8);
3990             SvCUR_set(dest, need - 1);
3991         }
3992     }
3993     SvSETMAGIC(dest);
3994     RETURN;
3995 }
3996
3997 /* There's so much setup/teardown code common between uc and lc, I wonder if
3998    it would be worth merging the two, and just having a switch outside each
3999    of the three tight loops.  There is less and less commonality though */
4000 PP(pp_uc)
4001 {
4002     dVAR;
4003     dSP;
4004     SV *source = TOPs;
4005     STRLEN len;
4006     STRLEN min;
4007     SV *dest;
4008     const U8 *s;
4009     U8 *d;
4010
4011     SvGETMAGIC(source);
4012
4013     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4014         && SvTEMP(source) && !DO_UTF8(source)
4015         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4016
4017         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4018          * make the loop tight, so we overwrite the source with the dest before
4019          * looking at it, and we need to look at the original source
4020          * afterwards.  There would also need to be code added to handle
4021          * switching to not in-place in midstream if we run into characters
4022          * that change the length.
4023          */
4024         dest = source;
4025         s = d = (U8*)SvPV_force_nomg(source, len);
4026         min = len + 1;
4027     } else {
4028         dTARGET;
4029
4030         dest = TARG;
4031
4032         /* The old implementation would copy source into TARG at this point.
4033            This had the side effect that if source was undef, TARG was now
4034            an undefined SV with PADTMP set, and they don't warn inside
4035            sv_2pv_flags(). However, we're now getting the PV direct from
4036            source, which doesn't have PADTMP set, so it would warn. Hence the
4037            little games.  */
4038
4039         if (SvOK(source)) {
4040             s = (const U8*)SvPV_nomg_const(source, len);
4041         } else {
4042             if (ckWARN(WARN_UNINITIALIZED))
4043                 report_uninit(source);
4044             s = (const U8*)"";
4045             len = 0;
4046         }
4047         min = len + 1;
4048
4049         SvUPGRADE(dest, SVt_PV);
4050         d = (U8*)SvGROW(dest, min);
4051         (void)SvPOK_only(dest);
4052
4053         SETs(dest);
4054     }
4055
4056     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4057        to check DO_UTF8 again here.  */
4058
4059     if (DO_UTF8(source)) {
4060         const U8 *const send = s + len;
4061         U8 tmpbuf[UTF8_MAXBYTES+1];
4062
4063         /* All occurrences of these are to be moved to follow any other marks.
4064          * This is context-dependent.  We may not be passed enough context to
4065          * move the iota subscript beyond all of them, but we do the best we can
4066          * with what we're given.  The result is always better than if we
4067          * hadn't done this.  And, the problem would only arise if we are
4068          * passed a character without all its combining marks, which would be
4069          * the caller's mistake.  The information this is based on comes from a
4070          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4071          * itself) and so can't be checked properly to see if it ever gets
4072          * revised.  But the likelihood of it changing is remote */
4073         bool in_iota_subscript = FALSE;
4074
4075         while (s < send) {
4076             if (in_iota_subscript && ! is_utf8_mark(s)) {
4077                 /* A non-mark.  Time to output the iota subscript */
4078 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4079 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4080
4081                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4082                 in_iota_subscript = FALSE;
4083             }
4084
4085
4086 /* See comments at the first instance in this file of this ifdef */
4087 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4088
4089             /* If the UTF-8 character is invariant, then it is in the range
4090              * known by the standard macro; result is only one byte long */
4091             if (UTF8_IS_INVARIANT(*s)) {
4092                 *d++ = toUPPER(*s);
4093                 s++;
4094             }
4095             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4096
4097                 /* Likewise, if it fits in a byte, its case change is in our
4098                  * table */
4099                 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4100                 U8 upper = toUPPER_LATIN1_MOD(orig);
4101                 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4102                 s += 2;
4103             }
4104             else {
4105 #else
4106             {
4107 #endif
4108
4109                 /* Otherwise, need the general UTF-8 case.  Get the changed
4110                  * case value and copy it to the output buffer */
4111
4112                 const STRLEN u = UTF8SKIP(s);
4113                 STRLEN ulen;
4114
4115                 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4116                 if (uv == GREEK_CAPITAL_LETTER_IOTA
4117                     && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4118                 {
4119                     in_iota_subscript = TRUE;
4120                 }
4121                 else {
4122                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4123                         /* If the eventually required minimum size outgrows
4124                          * the available space, we need to grow. */
4125                         const UV o = d - (U8*)SvPVX_const(dest);
4126
4127                         /* If someone uppercases one million U+03B0s we
4128                          * SvGROW() one million times.  Or we could try
4129                          * guessing how much to allocate without allocating too
4130                          * much.  Such is life.  See corresponding comment in
4131                          * lc code for another option */
4132                         SvGROW(dest, min);
4133                         d = (U8*)SvPVX(dest) + o;
4134                     }
4135                     Copy(tmpbuf, d, ulen, U8);
4136                     d += ulen;
4137                 }
4138                 s += u;
4139             }
4140         }
4141         if (in_iota_subscript) {
4142             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4143         }
4144         SvUTF8_on(dest);
4145         *d = '\0';
4146         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4147     }
4148     else {      /* Not UTF-8 */
4149         if (len) {
4150             const U8 *const send = s + len;
4151
4152             /* Use locale casing if in locale; regular style if not treating
4153              * latin1 as having case; otherwise the latin1 casing.  Do the
4154              * whole thing in a tight loop, for speed, */
4155             if (IN_LOCALE_RUNTIME) {
4156                 TAINT;
4157                 SvTAINTED_on(dest);
4158                 for (; s < send; d++, s++)
4159                     *d = toUPPER_LC(*s);
4160             }
4161             else if (! IN_UNI_8_BIT) {
4162                 for (; s < send; d++, s++) {
4163                     *d = toUPPER(*s);
4164                 }
4165             }
4166             else {
4167                 for (; s < send; d++, s++) {
4168                     *d = toUPPER_LATIN1_MOD(*s);
4169                     if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4170
4171                     /* The mainstream case is the tight loop above.  To avoid
4172                      * extra tests in that, all three characters that require
4173                      * special handling are mapped by the MOD to the one tested
4174                      * just above.
4175                      * Use the source to distinguish between the three cases */
4176
4177                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4178
4179                         /* uc() of this requires 2 characters, but they are
4180                          * ASCII.  If not enough room, grow the string */
4181                         if (SvLEN(dest) < ++min) {
4182                             const UV o = d - (U8*)SvPVX_const(dest);
4183                             SvGROW(dest, min);
4184                             d = (U8*)SvPVX(dest) + o;
4185                         }
4186                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4187                         continue;   /* Back to the tight loop; still in ASCII */
4188                     }
4189
4190                     /* The other two special handling characters have their
4191                      * upper cases outside the latin1 range, hence need to be
4192                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4193                      * here we are somewhere in the middle of processing a
4194                      * non-UTF-8 string, and realize that we will have to convert
4195                      * the whole thing to UTF-8.  What to do?  There are
4196                      * several possibilities.  The simplest to code is to
4197                      * convert what we have so far, set a flag, and continue on
4198                      * in the loop.  The flag would be tested each time through
4199                      * the loop, and if set, the next character would be
4200                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4201                      * to slow down the mainstream case at all for this fairly
4202                      * rare case, so I didn't want to add a test that didn't
4203                      * absolutely have to be there in the loop, besides the
4204                      * possibility that it would get too complicated for
4205                      * optimizers to deal with.  Another possibility is to just
4206                      * give up, convert the source to UTF-8, and restart the
4207                      * function that way.  Another possibility is to convert
4208                      * both what has already been processed and what is yet to
4209                      * come separately to UTF-8, then jump into the loop that
4210                      * handles UTF-8.  But the most efficient time-wise of the
4211                      * ones I could think of is what follows, and turned out to
4212                      * not require much extra code.  */
4213
4214                     /* Convert what we have so far into UTF-8, telling the
4215                      * function that we know it should be converted, and to
4216                      * allow extra space for what we haven't processed yet.
4217                      * Assume the worst case space requirements for converting
4218                      * what we haven't processed so far: that it will require
4219                      * two bytes for each remaining source character, plus the
4220                      * NUL at the end.  This may cause the string pointer to
4221                      * move, so re-find it. */
4222
4223                     len = d - (U8*)SvPVX_const(dest);
4224                     SvCUR_set(dest, len);
4225                     len = sv_utf8_upgrade_flags_grow(dest,
4226                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4227                                                 (send -s) * 2 + 1);
4228                     d = (U8*)SvPVX(dest) + len;
4229
4230                     /* And append the current character's upper case in UTF-8 */
4231                     CAT_NON_LATIN1_UC(d, *s);
4232
4233                     /* Now process the remainder of the source, converting to
4234                      * upper and UTF-8.  If a resulting byte is invariant in
4235                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4236                      * append it to the output. */
4237
4238                     s++;
4239                     for (; s < send; s++) {
4240                         U8 upper = toUPPER_LATIN1_MOD(*s);
4241                         if UTF8_IS_INVARIANT(upper) {
4242                             *d++ = upper;
4243                         }
4244                         else {
4245                             CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4246                         }
4247                     }
4248
4249                     /* Here have processed the whole source; no need to continue
4250                      * with the outer loop.  Each character has been converted
4251                      * to upper case and converted to UTF-8 */
4252
4253                     break;
4254                 } /* End of processing all latin1-style chars */
4255             } /* End of processing all chars */
4256         } /* End of source is not empty */
4257
4258         if (source != dest) {
4259             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4260             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4261         }
4262     } /* End of isn't utf8 */
4263     SvSETMAGIC(dest);
4264     RETURN;
4265 }
4266
4267 PP(pp_lc)
4268 {
4269     dVAR;
4270     dSP;
4271     SV *source = TOPs;
4272     STRLEN len;
4273     STRLEN min;
4274     SV *dest;
4275     const U8 *s;
4276     U8 *d;
4277
4278     SvGETMAGIC(source);
4279
4280     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4281         && SvTEMP(source) && !DO_UTF8(source)) {
4282
4283         /* We can convert in place, as lowercasing anything in the latin1 range
4284          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4285         dest = source;
4286         s = d = (U8*)SvPV_force_nomg(source, len);
4287         min = len + 1;
4288     } else {
4289         dTARGET;
4290
4291         dest = TARG;
4292
4293         /* The old implementation would copy source into TARG at this point.
4294            This had the side effect that if source was undef, TARG was now
4295            an undefined SV with PADTMP set, and they don't warn inside
4296            sv_2pv_flags(). However, we're now getting the PV direct from
4297            source, which doesn't have PADTMP set, so it would warn. Hence the
4298            little games.  */
4299
4300         if (SvOK(source)) {
4301             s = (const U8*)SvPV_nomg_const(source, len);
4302         } else {
4303             if (ckWARN(WARN_UNINITIALIZED))
4304                 report_uninit(source);
4305             s = (const U8*)"";
4306             len = 0;
4307         }
4308         min = len + 1;
4309
4310         SvUPGRADE(dest, SVt_PV);
4311         d = (U8*)SvGROW(dest, min);
4312         (void)SvPOK_only(dest);
4313
4314         SETs(dest);
4315     }
4316
4317     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4318        to check DO_UTF8 again here.  */
4319
4320     if (DO_UTF8(source)) {
4321         const U8 *const send = s + len;
4322         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4323
4324         while (s < send) {
4325 /* See comments at the first instance in this file of this ifdef */
4326 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4327             if (UTF8_IS_INVARIANT(*s)) {
4328
4329                 /* Invariant characters use the standard mappings compiled in.
4330                  */
4331                 *d++ = toLOWER(*s);
4332                 s++;
4333             }
4334             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4335
4336                 /* As do the ones in the Latin1 range */
4337                 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4338                 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4339                 s += 2;
4340             }
4341             else {
4342 #endif
4343                 /* Here, is utf8 not in Latin-1 range, have to go out and get
4344                  * the mappings from the tables. */
4345
4346                 const STRLEN u = UTF8SKIP(s);
4347                 STRLEN ulen;
4348
4349 #ifndef CONTEXT_DEPENDENT_CASING
4350                 toLOWER_utf8(s, tmpbuf, &ulen);
4351 #else
4352 /* This is ifdefd out because it needs more work and thought.  It isn't clear
4353  * that we should do it.
4354  * A minor objection is that this is based on a hard-coded rule from the
4355  *  Unicode standard, and may change, but this is not very likely at all.
4356  *  mktables should check and warn if it does.
4357  * More importantly, if the sigma occurs at the end of the string, we don't
4358  * have enough context to know whether it is part of a larger string or going
4359  * to be or not.  It may be that we are passed a subset of the context, via
4360  * a \U...\E, for example, and we could conceivably know the larger context if
4361  * code were changed to pass that in.  But, if the string passed in is an
4362  * intermediate result, and the user concatenates two strings together
4363  * after we have made a final sigma, that would be wrong.  If the final sigma
4364  * occurs in the middle of the string we are working on, then we know that it
4365  * should be a final sigma, but otherwise we can't be sure. */
4366
4367                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4368
4369                 /* If the lower case is a small sigma, it may be that we need
4370                  * to change it to a final sigma.  This happens at the end of
4371                  * a word that contains more than just this character, and only
4372                  * when we started with a capital sigma. */
4373                 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4374                     s > send - len &&   /* Makes sure not the first letter */
4375                     utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4376                 ) {
4377
4378                     /* We use the algorithm in:
4379                      * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4380                      * is a CAPITAL SIGMA): If C is preceded by a sequence
4381                      * consisting of a cased letter and a case-ignorable
4382                      * sequence, and C is not followed by a sequence consisting
4383                      * of a case ignorable sequence and then a cased letter,
4384                      * then when lowercasing C, C becomes a final sigma */
4385
4386                     /* To determine if this is the end of a word, need to peek
4387                      * ahead.  Look at the next character */
4388                     const U8 *peek = s + u;
4389
4390                     /* Skip any case ignorable characters */
4391                     while (peek < send && is_utf8_case_ignorable(peek)) {
4392                         peek += UTF8SKIP(peek);
4393                     }
4394
4395                     /* If we reached the end of the string without finding any
4396                      * non-case ignorable characters, or if the next such one
4397                      * is not-cased, then we have met the conditions for it
4398                      * being a final sigma with regards to peek ahead, and so
4399                      * must do peek behind for the remaining conditions. (We
4400                      * know there is stuff behind to look at since we tested
4401                      * above that this isn't the first letter) */
4402                     if (peek >= send || ! is_utf8_cased(peek)) {
4403                         peek = utf8_hop(s, -1);
4404
4405                         /* Here are at the beginning of the first character
4406                          * before the original upper case sigma.  Keep backing
4407                          * up, skipping any case ignorable characters */
4408                         while (is_utf8_case_ignorable(peek)) {
4409                             peek = utf8_hop(peek, -1);
4410                         }
4411
4412                         /* Here peek points to the first byte of the closest
4413                          * non-case-ignorable character before the capital
4414                          * sigma.  If it is cased, then by the Unicode
4415                          * algorithm, we should use a small final sigma instead
4416                          * of what we have */
4417                         if (is_utf8_cased(peek)) {
4418                             STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4419                                         UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4420                         }
4421                     }
4422                 }
4423                 else {  /* Not a context sensitive mapping */
4424 #endif  /* End of commented out context sensitive */
4425                     if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4426
4427                         /* If the eventually required minimum size outgrows
4428                          * the available space, we need to grow. */
4429                         const UV o = d - (U8*)SvPVX_const(dest);
4430
4431                         /* If someone lowercases one million U+0130s we
4432                          * SvGROW() one million times.  Or we could try
4433                          * guessing how much to allocate without allocating too
4434                          * much.  Such is life.  Another option would be to
4435                          * grow an extra byte or two more each time we need to
4436                          * grow, which would cut down the million to 500K, with
4437                          * little waste */
4438                         SvGROW(dest, min);
4439                         d = (U8*)SvPVX(dest) + o;
4440                     }
4441 #ifdef CONTEXT_DEPENDENT_CASING
4442                 }
4443 #endif
4444                 /* Copy the newly lowercased letter to the output buffer we're
4445                  * building */
4446                 Copy(tmpbuf, d, ulen, U8);
4447                 d += ulen;
4448                 s += u;
4449 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4450             }
4451 #endif
4452         }   /* End of looping through the source string */
4453         SvUTF8_on(dest);
4454         *d = '\0';
4455         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4456     } else {    /* Not utf8 */
4457         if (len) {
4458             const U8 *const send = s + len;
4459
4460             /* Use locale casing if in locale; regular style if not treating
4461              * latin1 as having case; otherwise the latin1 casing.  Do the
4462              * whole thing in a tight loop, for speed, */
4463             if (IN_LOCALE_RUNTIME) {
4464                 TAINT;
4465                 SvTAINTED_on(dest);
4466                 for (; s < send; d++, s++)
4467                     *d = toLOWER_LC(*s);
4468             }
4469             else if (! IN_UNI_8_BIT) {
4470                 for (; s < send; d++, s++) {
4471                     *d = toLOWER(*s);
4472                 }
4473             }
4474             else {
4475                 for (; s < send; d++, s++) {
4476                     *d = toLOWER_LATIN1(*s);
4477                 }
4478             }
4479         }
4480         if (source != dest) {
4481             *d = '\0';
4482             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4483         }
4484     }
4485     SvSETMAGIC(dest);
4486     RETURN;
4487 }
4488
4489 PP(pp_quotemeta)
4490 {
4491     dVAR; dSP; dTARGET;
4492     SV * const sv = TOPs;
4493     STRLEN len;
4494     register const char *s = SvPV_const(sv,len);
4495
4496     SvUTF8_off(TARG);                           /* decontaminate */
4497     if (len) {
4498         register char *d;
4499         SvUPGRADE(TARG, SVt_PV);
4500         SvGROW(TARG, (len * 2) + 1);
4501         d = SvPVX(TARG);
4502         if (DO_UTF8(sv)) {
4503             while (len) {
4504                 if (UTF8_IS_CONTINUED(*s)) {
4505                     STRLEN ulen = UTF8SKIP(s);
4506                     if (ulen > len)
4507                         ulen = len;
4508                     len -= ulen;
4509                     while (ulen--)
4510                         *d++ = *s++;
4511                 }
4512                 else {
4513                     if (!isALNUM(*s))
4514                         *d++ = '\\';
4515                     *d++ = *s++;
4516                     len--;
4517                 }
4518             }
4519             SvUTF8_on(TARG);
4520         }
4521         else {
4522             while (len--) {
4523                 if (!isALNUM(*s))
4524                     *d++ = '\\';
4525                 *d++ = *s++;
4526             }
4527         }
4528         *d = '\0';
4529         SvCUR_set(TARG, d - SvPVX_const(TARG));
4530         (void)SvPOK_only_UTF8(TARG);
4531     }
4532     else
4533         sv_setpvn(TARG, s, len);
4534     SETTARG;
4535     RETURN;
4536 }
4537
4538 /* Arrays. */
4539
4540 PP(pp_aslice)
4541 {
4542     dVAR; dSP; dMARK; dORIGMARK;
4543     register AV *const av = MUTABLE_AV(POPs);
4544     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4545
4546     if (SvTYPE(av) == SVt_PVAV) {
4547         const I32 arybase = CopARYBASE_get(PL_curcop);
4548         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4549         bool can_preserve = FALSE;
4550
4551         if (localizing) {
4552             MAGIC *mg;
4553             HV *stash;
4554
4555             can_preserve = SvCANEXISTDELETE(av);
4556         }
4557
4558         if (lval && localizing) {
4559             register SV **svp;
4560             I32 max = -1;
4561             for (svp = MARK + 1; svp <= SP; svp++) {
4562                 const I32 elem = SvIV(*svp);
4563                 if (elem > max)
4564                     max = elem;
4565             }
4566             if (max > AvMAX(av))
4567                 av_extend(av, max);
4568         }
4569
4570         while (++MARK <= SP) {
4571             register SV **svp;
4572             I32 elem = SvIV(*MARK);
4573             bool preeminent = TRUE;
4574
4575             if (elem > 0)
4576                 elem -= arybase;
4577             if (localizing && can_preserve) {
4578                 /* If we can determine whether the element exist,
4579                  * Try to preserve the existenceness of a tied array
4580                  * element by using EXISTS and DELETE if possible.
4581                  * Fallback to FETCH and STORE otherwise. */
4582                 preeminent = av_exists(av, elem);
4583             }
4584
4585             svp = av_fetch(av, elem, lval);
4586             if (lval) {
4587                 if (!svp || *svp == &PL_sv_undef)
4588                     DIE(aTHX_ PL_no_aelem, elem);
4589                 if (localizing) {
4590                     if (preeminent)
4591                         save_aelem(av, elem, svp);
4592                     else
4593                         SAVEADELETE(av, elem);
4594                 }
4595             }
4596             *MARK = svp ? *svp : &PL_sv_undef;
4597         }
4598     }
4599     if (GIMME != G_ARRAY) {
4600         MARK = ORIGMARK;
4601         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4602         SP = MARK;
4603     }
4604     RETURN;
4605 }
4606
4607 PP(pp_aeach)
4608 {
4609     dVAR;
4610     dSP;
4611     AV *array = MUTABLE_AV(POPs);
4612     const I32 gimme = GIMME_V;
4613     IV *iterp = Perl_av_iter_p(aTHX_ array);
4614     const IV current = (*iterp)++;
4615
4616     if (current > av_len(array)) {
4617         *iterp = 0;
4618         if (gimme == G_SCALAR)
4619             RETPUSHUNDEF;
4620         else
4621             RETURN;
4622     }
4623
4624     EXTEND(SP, 2);
4625     mPUSHi(CopARYBASE_get(PL_curcop) + current);
4626     if (gimme == G_ARRAY) {
4627         SV **const element = av_fetch(array, current, 0);
4628         PUSHs(element ? *element : &PL_sv_undef);
4629     }
4630     RETURN;
4631 }
4632
4633 PP(pp_akeys)
4634 {
4635     dVAR;
4636     dSP;
4637     AV *array = MUTABLE_AV(POPs);
4638     const I32 gimme = GIMME_V;
4639
4640     *Perl_av_iter_p(aTHX_ array) = 0;
4641
4642     if (gimme == G_SCALAR) {
4643         dTARGET;
4644         PUSHi(av_len(array) + 1);
4645     }
4646     else if (gimme == G_ARRAY) {
4647         IV n = Perl_av_len(aTHX_ array);
4648         IV i = CopARYBASE_get(PL_curcop);
4649
4650         EXTEND(SP, n + 1);
4651
4652         if (PL_op->op_type == OP_AKEYS) {
4653             n += i;
4654             for (;  i <= n;  i++) {
4655                 mPUSHi(i);
4656             }
4657         }
4658         else {
4659             for (i = 0;  i <= n;  i++) {
4660                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4661                 PUSHs(elem ? *elem : &PL_sv_undef);
4662             }
4663         }
4664     }
4665     RETURN;
4666 }
4667
4668 /* Associative arrays. */
4669
4670 PP(pp_each)
4671 {
4672     dVAR;
4673     dSP;
4674     HV * hash = MUTABLE_HV(POPs);
4675     HE *entry;
4676     const I32 gimme = GIMME_V;
4677
4678     PUTBACK;
4679     /* might clobber stack_sp */
4680     entry = hv_iternext(hash);
4681     SPAGAIN;
4682
4683     EXTEND(SP, 2);
4684     if (entry) {
4685         SV* const sv = hv_iterkeysv(entry);
4686         PUSHs(sv);      /* won't clobber stack_sp */
4687         if (gimme == G_ARRAY) {
4688             SV *val;
4689             PUTBACK;
4690             /* might clobber stack_sp */
4691             val = hv_iterval(hash, entry);
4692             SPAGAIN;
4693             PUSHs(val);
4694         }
4695     }
4696     else if (gimme == G_SCALAR)
4697         RETPUSHUNDEF;
4698
4699     RETURN;
4700 }
4701
4702 STATIC OP *
4703 S_do_delete_local(pTHX)
4704 {
4705     dVAR;
4706     dSP;
4707     const I32 gimme = GIMME_V;
4708     const MAGIC *mg;
4709     HV *stash;
4710
4711     if (PL_op->op_private & OPpSLICE) {
4712         dMARK; dORIGMARK;
4713         SV * const osv = POPs;
4714         const bool tied = SvRMAGICAL(osv)
4715                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4716         const bool can_preserve = SvCANEXISTDELETE(osv)
4717                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4718         const U32 type = SvTYPE(osv);
4719         if (type == SVt_PVHV) {                 /* hash element */
4720             HV * const hv = MUTABLE_HV(osv);
4721             while (++MARK <= SP) {
4722                 SV * const keysv = *MARK;
4723                 SV *sv = NULL;
4724                 bool preeminent = TRUE;
4725                 if (can_preserve)
4726                     preeminent = hv_exists_ent(hv, keysv, 0);
4727                 if (tied) {
4728                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4729                     if (he)
4730                         sv = HeVAL(he);
4731                     else
4732                         preeminent = FALSE;
4733                 }
4734                 else {
4735                     sv = hv_delete_ent(hv, keysv, 0, 0);
4736                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4737                 }
4738                 if (preeminent) {
4739                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4740                     if (tied) {
4741                         *MARK = sv_mortalcopy(sv);
4742                         mg_clear(sv);
4743                     } else
4744                         *MARK = sv;
4745                 }
4746                 else {
4747                     SAVEHDELETE(hv, keysv);
4748                     *MARK = &PL_sv_undef;
4749                 }
4750             }
4751         }
4752         else if (type == SVt_PVAV) {                  /* array element */
4753             if (PL_op->op_flags & OPf_SPECIAL) {
4754                 AV * const av = MUTABLE_AV(osv);
4755                 while (++MARK <= SP) {
4756                     I32 idx = SvIV(*MARK);
4757                     SV *sv = NULL;
4758                     bool preeminent = TRUE;
4759                     if (can_preserve)
4760                         preeminent = av_exists(av, idx);
4761                     if (tied) {
4762                         SV **svp = av_fetch(av, idx, 1);
4763                         if (svp)
4764                             sv = *svp;
4765                         else
4766                             preeminent = FALSE;
4767                     }
4768                     else {
4769                         sv = av_delete(av, idx, 0);
4770                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4771                     }
4772                     if (preeminent) {
4773                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4774                         if (tied) {
4775                             *MARK = sv_mortalcopy(sv);
4776                             mg_clear(sv);
4777                         } else
4778                             *MARK = sv;
4779                     }
4780                     else {
4781                         SAVEADELETE(av, idx);
4782                         *MARK = &PL_sv_undef;
4783                     }
4784                 }
4785             }
4786         }
4787         else
4788             DIE(aTHX_ "Not a HASH reference");
4789         if (gimme == G_VOID)
4790             SP = ORIGMARK;
4791         else if (gimme == G_SCALAR) {
4792             MARK = ORIGMARK;
4793             if (SP > MARK)
4794                 *++MARK = *SP;
4795             else
4796                 *++MARK = &PL_sv_undef;
4797             SP = MARK;
4798         }
4799     }
4800     else {
4801         SV * const keysv = POPs;
4802         SV * const osv   = POPs;
4803         const bool tied = SvRMAGICAL(osv)
4804                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4805         const bool can_preserve = SvCANEXISTDELETE(osv)
4806                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4807         const U32 type = SvTYPE(osv);
4808         SV *sv = NULL;
4809         if (type == SVt_PVHV) {
4810             HV * const hv = MUTABLE_HV(osv);
4811             bool preeminent = TRUE;
4812             if (can_preserve)
4813                 preeminent = hv_exists_ent(hv, keysv, 0);
4814             if (tied) {
4815                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4816                 if (he)
4817                     sv = HeVAL(he);
4818                 else
4819                     preeminent = FALSE;
4820             }
4821             else {
4822                 sv = hv_delete_ent(hv, keysv, 0, 0);
4823                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4824             }
4825             if (preeminent) {
4826                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4827                 if (tied) {
4828                     SV *nsv = sv_mortalcopy(sv);
4829                     mg_clear(sv);
4830                     sv = nsv;
4831                 }
4832             }
4833             else
4834                 SAVEHDELETE(hv, keysv);
4835         }
4836         else if (type == SVt_PVAV) {
4837             if (PL_op->op_flags & OPf_SPECIAL) {
4838                 AV * const av = MUTABLE_AV(osv);
4839                 I32 idx = SvIV(keysv);
4840                 bool preeminent = TRUE;
4841                 if (can_preserve)
4842                     preeminent = av_exists(av, idx);
4843                 if (tied) {
4844                     SV **svp = av_fetch(av, idx, 1);
4845                     if (svp)
4846                         sv = *svp;
4847                     else
4848                         preeminent = FALSE;
4849                 }
4850                 else {
4851                     sv = av_delete(av, idx, 0);
4852                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4853                 }
4854                 if (preeminent) {
4855                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4856                     if (tied) {
4857                         SV *nsv = sv_mortalcopy(sv);
4858                         mg_clear(sv);
4859                         sv = nsv;
4860                     }
4861                 }
4862                 else
4863                     SAVEADELETE(av, idx);
4864             }
4865             else
4866                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4867         }
4868         else
4869             DIE(aTHX_ "Not a HASH reference");
4870         if (!sv)
4871             sv = &PL_sv_undef;
4872         if (gimme != G_VOID)
4873             PUSHs(sv);
4874     }
4875
4876     RETURN;
4877 }
4878
4879 PP(pp_delete)
4880 {
4881     dVAR;
4882     dSP;
4883     I32 gimme;
4884     I32 discard;
4885
4886     if (PL_op->op_private & OPpLVAL_INTRO)
4887         return do_delete_local();
4888
4889     gimme = GIMME_V;
4890     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4891
4892     if (PL_op->op_private & OPpSLICE) {
4893         dMARK; dORIGMARK;
4894         HV * const hv = MUTABLE_HV(POPs);
4895         const U32 hvtype = SvTYPE(hv);
4896         if (hvtype == SVt_PVHV) {                       /* hash element */
4897             while (++MARK <= SP) {
4898                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4899                 *MARK = sv ? sv : &PL_sv_undef;
4900             }
4901         }
4902         else if (hvtype == SVt_PVAV) {                  /* array element */
4903             if (PL_op->op_flags & OPf_SPECIAL) {
4904                 while (++MARK <= SP) {
4905                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4906                     *MARK = sv ? sv : &PL_sv_undef;
4907                 }
4908             }
4909         }
4910         else
4911             DIE(aTHX_ "Not a HASH reference");
4912         if (discard)
4913             SP = ORIGMARK;
4914         else if (gimme == G_SCALAR) {
4915             MARK = ORIGMARK;
4916             if (SP > MARK)
4917                 *++MARK = *SP;
4918             else
4919                 *++MARK = &PL_sv_undef;
4920             SP = MARK;
4921         }
4922     }
4923     else {
4924         SV *keysv = POPs;
4925         HV * const hv = MUTABLE_HV(POPs);
4926         SV *sv = NULL;
4927         if (SvTYPE(hv) == SVt_PVHV)
4928             sv = hv_delete_ent(hv, keysv, discard, 0);
4929         else if (SvTYPE(hv) == SVt_PVAV) {
4930             if (PL_op->op_flags & OPf_SPECIAL)
4931                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4932             else
4933                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4934         }
4935         else
4936             DIE(aTHX_ "Not a HASH reference");
4937         if (!sv)
4938             sv = &PL_sv_undef;
4939         if (!discard)
4940             PUSHs(sv);
4941     }
4942     RETURN;
4943 }
4944
4945 PP(pp_exists)
4946 {
4947     dVAR;
4948     dSP;
4949     SV *tmpsv;
4950     HV *hv;
4951
4952     if (PL_op->op_private & OPpEXISTS_SUB) {
4953         GV *gv;
4954         SV * const sv = POPs;
4955         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4956         if (cv)
4957             RETPUSHYES;
4958         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4959             RETPUSHYES;
4960         RETPUSHNO;
4961     }
4962     tmpsv = POPs;
4963     hv = MUTABLE_HV(POPs);
4964     if (SvTYPE(hv) == SVt_PVHV) {
4965         if (hv_exists_ent(hv, tmpsv, 0))
4966             RETPUSHYES;
4967     }
4968     else if (SvTYPE(hv) == SVt_PVAV) {
4969         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4970             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4971                 RETPUSHYES;
4972         }
4973     }
4974     else {
4975         DIE(aTHX_ "Not a HASH reference");
4976     }
4977     RETPUSHNO;
4978 }
4979
4980 PP(pp_hslice)
4981 {
4982     dVAR; dSP; dMARK; dORIGMARK;
4983     register HV * const hv = MUTABLE_HV(POPs);
4984     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4985     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4986     bool can_preserve = FALSE;
4987
4988     if (localizing) {
4989         MAGIC *mg;
4990         HV *stash;
4991
4992         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4993             can_preserve = TRUE;
4994     }
4995
4996     while (++MARK <= SP) {
4997         SV * const keysv = *MARK;
4998         SV **svp;
4999         HE *he;
5000         bool preeminent = TRUE;
5001
5002         if (localizing && can_preserve) {
5003             /* If we can determine whether the element exist,
5004              * try to preserve the existenceness of a tied hash
5005              * element by using EXISTS and DELETE if possible.
5006              * Fallback to FETCH and STORE otherwise. */
5007             preeminent = hv_exists_ent(hv, keysv, 0);
5008         }
5009
5010         he = hv_fetch_ent(hv, keysv, lval, 0);
5011         svp = he ? &HeVAL(he) : NULL;
5012
5013         if (lval) {
5014             if (!svp || *svp == &PL_sv_undef) {
5015                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5016             }
5017             if (localizing) {
5018                 if (HvNAME_get(hv) && isGV(*svp))
5019                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5020                 else if (preeminent)
5021                     save_helem_flags(hv, keysv, svp,
5022                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5023                 else
5024                     SAVEHDELETE(hv, keysv);
5025             }
5026         }
5027         *MARK = svp ? *svp : &PL_sv_undef;
5028     }
5029     if (GIMME != G_ARRAY) {
5030         MARK = ORIGMARK;
5031         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5032         SP = MARK;
5033     }
5034     RETURN;
5035 }
5036
5037 /* List operators. */
5038
5039 PP(pp_list)
5040 {
5041     dVAR; dSP; dMARK;
5042     if (GIMME != G_ARRAY) {
5043         if (++MARK <= SP)
5044             *MARK = *SP;                /* unwanted list, return last item */
5045         else
5046             *MARK = &PL_sv_undef;
5047         SP = MARK;
5048     }
5049     RETURN;
5050 }
5051
5052 PP(pp_lslice)
5053 {
5054     dVAR;
5055     dSP;
5056     SV ** const lastrelem = PL_stack_sp;
5057     SV ** const lastlelem = PL_stack_base + POPMARK;
5058     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5059     register SV ** const firstrelem = lastlelem + 1;
5060     const I32 arybase = CopARYBASE_get(PL_curcop);
5061     I32 is_something_there = FALSE;
5062
5063     register const I32 max = lastrelem - lastlelem;
5064     register SV **lelem;
5065
5066     if (GIMME != G_ARRAY) {
5067         I32 ix = SvIV(*lastlelem);
5068         if (ix < 0)
5069             ix += max;
5070         else
5071             ix -= arybase;
5072         if (ix < 0 || ix >= max)
5073             *firstlelem = &PL_sv_undef;
5074         else
5075             *firstlelem = firstrelem[ix];
5076         SP = firstlelem;
5077         RETURN;
5078     }
5079
5080     if (max == 0) {
5081         SP = firstlelem - 1;
5082         RETURN;
5083     }
5084
5085     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5086         I32 ix = SvIV(*lelem);
5087         if (ix < 0)
5088             ix += max;
5089         else
5090             ix -= arybase;
5091         if (ix < 0 || ix >= max)
5092             *lelem = &PL_sv_undef;
5093         else {
5094             is_something_there = TRUE;
5095             if (!(*lelem = firstrelem[ix]))
5096                 *lelem = &PL_sv_undef;
5097         }
5098     }
5099     if (is_something_there)
5100         SP = lastlelem;
5101     else
5102         SP = firstlelem - 1;
5103     RETURN;
5104 }
5105
5106 PP(pp_anonlist)
5107 {
5108     dVAR; dSP; dMARK; dORIGMARK;
5109     const I32 items = SP - MARK;
5110     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5111     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
5112     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5113             ? newRV_noinc(av) : av);
5114     RETURN;
5115 }
5116
5117 PP(pp_anonhash)
5118 {
5119     dVAR; dSP; dMARK; dORIGMARK;
5120     HV* const hv = newHV();
5121
5122     while (MARK < SP) {
5123         SV * const key = *++MARK;
5124         SV * const val = newSV(0);
5125         if (MARK < SP)
5126             sv_setsv(val, *++MARK);
5127         else
5128             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5129         (void)hv_store_ent(hv,key,val,0);
5130     }
5131     SP = ORIGMARK;
5132     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5133             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5134     RETURN;
5135 }
5136
5137 PP(pp_splice)
5138 {
5139     dVAR; dSP; dMARK; dORIGMARK;
5140     register AV *ary = MUTABLE_AV(*++MARK);
5141     register SV **src;
5142     register SV **dst;
5143     register I32 i;
5144     register I32 offset;
5145     register I32 length;
5146     I32 newlen;
5147     I32 after;
5148     I32 diff;
5149     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5150
5151     if (mg) {
5152         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5153         PUSHMARK(MARK);
5154         PUTBACK;
5155         ENTER_with_name("call_SPLICE");
5156         call_method("SPLICE",GIMME_V);
5157         LEAVE_with_name("call_SPLICE");
5158         SPAGAIN;
5159         RETURN;
5160     }
5161
5162     SP++;
5163
5164     if (++MARK < SP) {
5165         offset = i = SvIV(*MARK);
5166         if (offset < 0)
5167             offset += AvFILLp(ary) + 1;
5168         else
5169             offset -= CopARYBASE_get(PL_curcop);
5170         if (offset < 0)
5171             DIE(aTHX_ PL_no_aelem, i);
5172         if (++MARK < SP) {
5173             length = SvIVx(*MARK++);
5174             if (length < 0) {
5175                 length += AvFILLp(ary) - offset + 1;
5176                 if (length < 0)
5177                     length = 0;
5178             }
5179         }
5180         else
5181             length = AvMAX(ary) + 1;            /* close enough to infinity */
5182     }
5183     else {
5184         offset = 0;
5185         length = AvMAX(ary) + 1;
5186     }
5187     if (offset > AvFILLp(ary) + 1) {
5188         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5189         offset = AvFILLp(ary) + 1;
5190     }
5191     after = AvFILLp(ary) + 1 - (offset + length);
5192     if (after < 0) {                            /* not that much array */
5193         length += after;                        /* offset+length now in array */
5194         after = 0;
5195         if (!AvALLOC(ary))
5196             av_extend(ary, 0);
5197     }
5198
5199     /* At this point, MARK .. SP-1 is our new LIST */
5200
5201     newlen = SP - MARK;
5202     diff = newlen - length;
5203     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5204         av_reify(ary);
5205
5206     /* make new elements SVs now: avoid problems if they're from the array */
5207     for (dst = MARK, i = newlen; i; i--) {
5208         SV * const h = *dst;
5209         *dst++ = newSVsv(h);
5210     }
5211
5212     if (diff < 0) {                             /* shrinking the area */
5213         SV **tmparyval = NULL;
5214         if (newlen) {
5215             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5216             Copy(MARK, tmparyval, newlen, SV*);
5217         }
5218
5219         MARK = ORIGMARK + 1;
5220         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5221             MEXTEND(MARK, length);
5222             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5223             if (AvREAL(ary)) {
5224                 EXTEND_MORTAL(length);
5225                 for (i = length, dst = MARK; i; i--) {
5226                     sv_2mortal(*dst);   /* free them eventualy */
5227                     dst++;
5228                 }
5229             }
5230             MARK += length - 1;
5231         }
5232         else {
5233             *MARK = AvARRAY(ary)[offset+length-1];
5234             if (AvREAL(ary)) {
5235                 sv_2mortal(*MARK);
5236                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5237                     SvREFCNT_dec(*dst++);       /* free them now */
5238             }
5239         }
5240         AvFILLp(ary) += diff;
5241
5242         /* pull up or down? */
5243
5244         if (offset < after) {                   /* easier to pull up */
5245             if (offset) {                       /* esp. if nothing to pull */
5246                 src = &AvARRAY(ary)[offset-1];
5247                 dst = src - diff;               /* diff is negative */
5248                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5249                     *dst-- = *src--;
5250             }
5251             dst = AvARRAY(ary);
5252             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5253             AvMAX(ary) += diff;
5254         }
5255         else {
5256             if (after) {                        /* anything to pull down? */
5257                 src = AvARRAY(ary) + offset + length;
5258                 dst = src + diff;               /* diff is negative */
5259                 Move(src, dst, after, SV*);
5260             }
5261             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5262                                                 /* avoid later double free */
5263         }
5264         i = -diff;
5265         while (i)
5266             dst[--i] = &PL_sv_undef;
5267
5268         if (newlen) {
5269             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5270             Safefree(tmparyval);
5271         }
5272     }
5273     else {                                      /* no, expanding (or same) */
5274         SV** tmparyval = NULL;
5275         if (length) {
5276             Newx(tmparyval, length, SV*);       /* so remember deletion */
5277             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5278         }
5279
5280         if (diff > 0) {                         /* expanding */
5281             /* push up or down? */
5282             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5283                 if (offset) {
5284                     src = AvARRAY(ary);
5285                     dst = src - diff;
5286                     Move(src, dst, offset, SV*);
5287                 }
5288                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5289                 AvMAX(ary) += diff;
5290                 AvFILLp(ary) += diff;
5291             }
5292             else {
5293                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5294                     av_extend(ary, AvFILLp(ary) + diff);
5295                 AvFILLp(ary) += diff;
5296
5297                 if (after) {
5298                     dst = AvARRAY(ary) + AvFILLp(ary);
5299                     src = dst - diff;
5300                     for (i = after; i; i--) {
5301                         *dst-- = *src--;
5302                     }
5303                 }
5304             }
5305         }
5306
5307         if (newlen) {
5308             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5309         }
5310
5311         MARK = ORIGMARK + 1;
5312         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
5313             if (length) {
5314                 Copy(tmparyval, MARK, length, SV*);
5315                 if (AvREAL(ary)) {
5316                     EXTEND_MORTAL(length);
5317                     for (i = length, dst = MARK; i; i--) {
5318                         sv_2mortal(*dst);       /* free them eventualy */
5319                         dst++;
5320                     }
5321                 }
5322             }
5323             MARK += length - 1;
5324         }
5325         else if (length--) {
5326             *MARK = tmparyval[length];
5327             if (AvREAL(ary)) {
5328                 sv_2mortal(*MARK);
5329                 while (length-- > 0)
5330                     SvREFCNT_dec(tmparyval[length]);
5331             }
5332         }
5333         else
5334             *MARK = &PL_sv_undef;
5335         Safefree(tmparyval);
5336     }
5337     SP = MARK;
5338     RETURN;
5339 }
5340
5341 PP(pp_push)
5342 {
5343     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5344     register AV * const ary = MUTABLE_AV(*++MARK);
5345     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5346
5347     if (mg) {
5348         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5349         PUSHMARK(MARK);
5350         PUTBACK;
5351         ENTER_with_name("call_PUSH");
5352         call_method("PUSH",G_SCALAR|G_DISCARD);
5353         LEAVE_with_name("call_PUSH");
5354         SPAGAIN;
5355     }
5356     else {
5357         PL_delaymagic = DM_DELAY;
5358         for (++MARK; MARK <= SP; MARK++) {
5359             SV * const sv = newSV(0);
5360             if (*MARK)
5361                 sv_setsv(sv, *MARK);
5362             av_store(ary, AvFILLp(ary)+1, sv);
5363         }
5364         if (PL_delaymagic & DM_ARRAY_ISA)
5365             mg_set(MUTABLE_SV(ary));
5366
5367         PL_delaymagic = 0;
5368     }
5369     SP = ORIGMARK;
5370     if (OP_GIMME(PL_op, 0) != G_VOID) {
5371         PUSHi( AvFILL(ary) + 1 );
5372     }
5373     RETURN;
5374 }
5375
5376 PP(pp_shift)
5377 {
5378     dVAR;
5379     dSP;
5380     AV * const av = PL_op->op_flags & OPf_SPECIAL
5381         ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5382     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5383     EXTEND(SP, 1);
5384     assert (sv);
5385     if (AvREAL(av))
5386         (void)sv_2mortal(sv);
5387     PUSHs(sv);
5388     RETURN;
5389 }
5390
5391 PP(pp_unshift)
5392 {
5393     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5394     register AV *ary = MUTABLE_AV(*++MARK);
5395     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5396
5397     if (mg) {
5398         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5399         PUSHMARK(MARK);
5400         PUTBACK;
5401         ENTER_with_name("call_UNSHIFT");
5402         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5403         LEAVE_with_name("call_UNSHIFT");
5404         SPAGAIN;
5405     }
5406     else {
5407         register I32 i = 0;
5408         av_unshift(ary, SP - MARK);
5409         while (MARK < SP) {
5410             SV * const sv = newSVsv(*++MARK);
5411             (void)av_store(ary, i++, sv);
5412         }
5413     }
5414     SP = ORIGMARK;
5415     if (OP_GIMME(PL_op, 0) != G_VOID) {
5416         PUSHi( AvFILL(ary) + 1 );
5417     }
5418     RETURN;
5419 }
5420
5421 PP(pp_reverse)
5422 {
5423     dVAR; dSP; dMARK;
5424
5425     if (GIMME == G_ARRAY) {
5426         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5427             AV *av;
5428
5429             /* See pp_sort() */
5430             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5431             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5432             av = MUTABLE_AV((*SP));
5433             /* In-place reversing only happens in void context for the array
5434              * assignment. We don't need to push anything on the stack. */
5435             SP = MARK;
5436
5437             if (SvMAGICAL(av)) {
5438                 I32 i, j;
5439                 register SV *tmp = sv_newmortal();
5440                 /* For SvCANEXISTDELETE */
5441                 HV *stash;
5442                 const MAGIC *mg;
5443                 bool can_preserve = SvCANEXISTDELETE(av);
5444
5445                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5446                     register SV *begin, *end;
5447
5448                     if (can_preserve) {
5449                         if (!av_exists(av, i)) {
5450                             if (av_exists(av, j)) {
5451                                 register SV *sv = av_delete(av, j, 0);
5452                                 begin = *av_fetch(av, i, TRUE);
5453                                 sv_setsv_mg(begin, sv);
5454                             }
5455                             continue;
5456                         }
5457                         else if (!av_exists(av, j)) {
5458                             register SV *sv = av_delete(av, i, 0);
5459                             end = *av_fetch(av, j, TRUE);
5460                             sv_setsv_mg(end, sv);
5461                             continue;
5462                         }
5463                     }
5464
5465                     begin = *av_fetch(av, i, TRUE);
5466                     end   = *av_fetch(av, j, TRUE);
5467                     sv_setsv(tmp,      begin);
5468                     sv_setsv_mg(begin, end);
5469                     sv_setsv_mg(end,   tmp);
5470                 }
5471             }
5472             else {
5473                 SV **begin = AvARRAY(av);
5474
5475                 if (begin) {
5476                     SV **end   = begin + AvFILLp(av);
5477
5478                     while (begin < end) {
5479                         register SV * const tmp = *begin;
5480                         *begin++ = *end;
5481                         *end--   = tmp;
5482                     }
5483                 }
5484             }
5485         }
5486         else {
5487             SV **oldsp = SP;
5488             MARK++;
5489             while (MARK < SP) {
5490                 register SV * const tmp = *MARK;
5491                 *MARK++ = *SP;
5492                 *SP--   = tmp;
5493             }
5494             /* safe as long as stack cannot get extended in the above */
5495             SP = oldsp;
5496         }
5497     }
5498     else {
5499         register char *up;
5500         register char *down;
5501         register I32 tmp;
5502         dTARGET;
5503         STRLEN len;
5504
5505         SvUTF8_off(TARG);                               /* decontaminate */
5506         if (SP - MARK > 1)
5507             do_join(TARG, &PL_sv_no, MARK, SP);
5508         else {
5509             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5510             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5511                 report_uninit(TARG);
5512         }
5513
5514         up = SvPV_force(TARG, len);
5515         if (len > 1) {
5516             if (DO_UTF8(TARG)) {        /* first reverse each character */
5517                 U8* s = (U8*)SvPVX(TARG);
5518                 const U8* send = (U8*)(s + len);
5519                 while (s < send) {
5520                     if (UTF8_IS_INVARIANT(*s)) {
5521                         s++;
5522                         continue;
5523                     }
5524                     else {
5525                         if (!utf8_to_uvchr(s, 0))
5526                             break;
5527                         up = (char*)s;
5528                         s += UTF8SKIP(s);
5529                         down = (char*)(s - 1);
5530                         /* reverse this character */
5531                         while (down > up) {
5532                             tmp = *up;
5533                             *up++ = *down;
5534                             *down-- = (char)tmp;
5535                         }
5536                     }
5537                 }
5538                 up = SvPVX(TARG);
5539             }
5540             down = SvPVX(TARG) + len - 1;
5541             while (down > up) {
5542                 tmp = *up;
5543                 *up++ = *down;
5544                 *down-- = (char)tmp;
5545             }
5546             (void)SvPOK_only_UTF8(TARG);
5547         }
5548         SP = MARK + 1;
5549         SETTARG;
5550     }
5551     RETURN;
5552 }
5553
5554 PP(pp_split)
5555 {
5556     dVAR; dSP; dTARG;
5557     AV *ary;
5558     register IV limit = POPi;                   /* note, negative is forever */
5559     SV * const sv = POPs;
5560     STRLEN len;
5561     register const char *s = SvPV_const(sv, len);
5562     const bool do_utf8 = DO_UTF8(sv);
5563     const char *strend = s + len;
5564     register PMOP *pm;
5565     register REGEXP *rx;
5566     register SV *dstr;
5567     register const char *m;
5568     I32 iters = 0;
5569     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5570     I32 maxiters = slen + 10;
5571     I32 trailing_empty = 0;
5572     const char *orig;
5573     const I32 origlimit = limit;
5574     I32 realarray = 0;
5575     I32 base;
5576     const I32 gimme = GIMME_V;
5577     bool gimme_scalar;
5578     const I32 oldsave = PL_savestack_ix;
5579     U32 make_mortal = SVs_TEMP;
5580     bool multiline = 0;
5581     MAGIC *mg = NULL;
5582
5583 #ifdef DEBUGGING
5584     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5585 #else
5586     pm = (PMOP*)POPs;
5587 #endif
5588     if (!pm || !s)
5589         DIE(aTHX_ "panic: pp_split");
5590     rx = PM_GETRE(pm);
5591
5592     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5593              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5594
5595     RX_MATCH_UTF8_set(rx, do_utf8);
5596
5597 #ifdef USE_ITHREADS
5598     if (pm->op_pmreplrootu.op_pmtargetoff) {
5599         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5600     }
5601 #else
5602     if (pm->op_pmreplrootu.op_pmtargetgv) {
5603         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5604     }
5605 #endif
5606     else
5607         ary = NULL;
5608     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5609         realarray = 1;
5610         PUTBACK;
5611         av_extend(ary,0);
5612         av_clear(ary);
5613         SPAGAIN;
5614         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5615             PUSHMARK(SP);
5616             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5617         }
5618         else {
5619             if (!AvREAL(ary)) {
5620                 I32 i;
5621                 AvREAL_on(ary);
5622                 AvREIFY_off(ary);
5623                 for (i = AvFILLp(ary); i >= 0; i--)
5624                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5625             }
5626             /* temporarily switch stacks */
5627             SAVESWITCHSTACK(PL_curstack, ary);
5628             make_mortal = 0;
5629         }
5630     }
5631     base = SP - PL_stack_base;
5632     orig = s;
5633     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5634         if (do_utf8) {
5635             while (*s == ' ' || is_utf8_space((U8*)s))
5636                 s += UTF8SKIP(s);
5637         }
5638         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5639             while (isSPACE_LC(*s))
5640                 s++;
5641         }
5642         else {
5643             while (isSPACE(*s))
5644                 s++;
5645         }
5646     }
5647     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5648         multiline = 1;
5649     }
5650
5651     gimme_scalar = gimme == G_SCALAR && !ary;
5652
5653     if (!limit)
5654         limit = maxiters + 2;
5655     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5656         while (--limit) {
5657             m = s;
5658             /* this one uses 'm' and is a negative test */
5659             if (do_utf8) {
5660                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5661                     const int t = UTF8SKIP(m);
5662                     /* is_utf8_space returns FALSE for malform utf8 */
5663                     if (strend - m < t)
5664                         m = strend;
5665                     else
5666                         m += t;
5667                 }
5668             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5669                 while (m < strend && !isSPACE_LC(*m))
5670                     ++m;
5671             } else {
5672                 while (m < strend && !isSPACE(*m))
5673                     ++m;
5674             }
5675             if (m >= strend)
5676                 break;
5677
5678             if (gimme_scalar) {
5679                 iters++;
5680                 if (m-s == 0)
5681                     trailing_empty++;
5682                 else
5683                     trailing_empty = 0;
5684             } else {
5685                 dstr = newSVpvn_flags(s, m-s,
5686                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5687                 XPUSHs(dstr);
5688             }
5689
5690             /* skip the whitespace found last */
5691             if (do_utf8)
5692                 s = m + UTF8SKIP(m);
5693             else
5694                 s = m + 1;
5695
5696             /* this one uses 's' and is a positive test */
5697             if (do_utf8) {
5698                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5699                     s +=  UTF8SKIP(s);
5700             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5701                 while (s < strend && isSPACE_LC(*s))
5702                     ++s;
5703             } else {
5704                 while (s < strend && isSPACE(*s))
5705                     ++s;
5706             }
5707         }
5708     }
5709     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5710         while (--limit) {
5711             for (m = s; m < strend && *m != '\n'; m++)
5712                 ;
5713             m++;
5714             if (m >= strend)
5715                 break;
5716
5717             if (gimme_scalar) {
5718                 iters++;
5719                 if (m-s == 0)
5720                     trailing_empty++;
5721                 else
5722                     trailing_empty = 0;
5723             } else {
5724                 dstr = newSVpvn_flags(s, m-s,
5725                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5726                 XPUSHs(dstr);
5727             }
5728             s = m;
5729         }
5730     }
5731     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5732         /*
5733           Pre-extend the stack, either the number of bytes or
5734           characters in the string or a limited amount, triggered by:
5735
5736           my ($x, $y) = split //, $str;
5737             or
5738           split //, $str, $i;
5739         */
5740         if (!gimme_scalar) {
5741             const U32 items = limit - 1;
5742             if (items < slen)
5743                 EXTEND(SP, items);
5744             else
5745                 EXTEND(SP, slen);
5746         }
5747
5748         if (do_utf8) {
5749             while (--limit) {
5750                 /* keep track of how many bytes we skip over */
5751                 m = s;
5752                 s += UTF8SKIP(s);
5753                 if (gimme_scalar) {
5754                     iters++;
5755                     if (s-m == 0)
5756                         trailing_empty++;
5757                     else
5758                         trailing_empty = 0;
5759                 } else {
5760                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5761
5762                     PUSHs(dstr);
5763                 }
5764
5765                 if (s >= strend)
5766                     break;
5767             }
5768         } else {
5769             while (--limit) {
5770                 if (gimme_scalar) {
5771                     iters++;
5772                 } else {
5773                     dstr = newSVpvn(s, 1);
5774
5775
5776                     if (make_mortal)
5777                         sv_2mortal(dstr);
5778
5779                     PUSHs(dstr);
5780                 }
5781
5782                 s++;
5783
5784                 if (s >= strend)
5785                     break;
5786             }
5787         }
5788     }
5789     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5790              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5791              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5792              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5793         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5794         SV * const csv = CALLREG_INTUIT_STRING(rx);
5795
5796         len = RX_MINLENRET(rx);
5797         if (len == 1 && !RX_UTF8(rx) && !tail) {
5798             const char c = *SvPV_nolen_const(csv);
5799             while (--limit) {
5800                 for (m = s; m < strend && *m != c; m++)
5801                     ;
5802                 if (m >= strend)
5803                     break;
5804                 if (gimme_scalar) {
5805                     iters++;
5806                     if (m-s == 0)
5807                         trailing_empty++;
5808                     else
5809                         trailing_empty = 0;
5810                 } else {
5811                     dstr = newSVpvn_flags(s, m-s,
5812                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5813                     XPUSHs(dstr);
5814                 }
5815                 /* The rx->minlen is in characters but we want to step
5816                  * s ahead by bytes. */
5817                 if (do_utf8)
5818                     s = (char*)utf8_hop((U8*)m, len);
5819                 else
5820                     s = m + len; /* Fake \n at the end */
5821             }
5822         }
5823         else {
5824             while (s < strend && --limit &&
5825               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5826                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5827             {
5828                 if (gimme_scalar) {
5829                     iters++;
5830                     if (m-s == 0)
5831                         trailing_empty++;
5832                     else
5833                         trailing_empty = 0;
5834                 } else {
5835                     dstr = newSVpvn_flags(s, m-s,
5836                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5837                     XPUSHs(dstr);
5838                 }
5839                 /* The rx->minlen is in characters but we want to step
5840                  * s ahead by bytes. */
5841                 if (do_utf8)
5842                     s = (char*)utf8_hop((U8*)m, len);
5843                 else
5844                     s = m + len; /* Fake \n at the end */
5845             }
5846         }
5847     }
5848     else {
5849         maxiters += slen * RX_NPARENS(rx);
5850         while (s < strend && --limit)
5851         {
5852             I32 rex_return;
5853             PUTBACK;
5854             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5855                             sv, NULL, 0);
5856             SPAGAIN;
5857             if (rex_return == 0)
5858                 break;
5859             TAINT_IF(RX_MATCH_TAINTED(rx));
5860             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5861                 m = s;
5862                 s = orig;
5863                 orig = RX_SUBBEG(rx);
5864                 s = orig + (m - s);
5865                 strend = s + (strend - m);
5866             }
5867             m = RX_OFFS(rx)[0].start + orig;
5868
5869             if (gimme_scalar) {
5870                 iters++;
5871                 if (m-s == 0)
5872                     trailing_empty++;
5873                 else
5874                     trailing_empty = 0;
5875             } else {
5876                 dstr = newSVpvn_flags(s, m-s,
5877                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5878                 XPUSHs(dstr);
5879             }
5880             if (RX_NPARENS(rx)) {
5881                 I32 i;
5882                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5883                     s = RX_OFFS(rx)[i].start + orig;
5884                     m = RX_OFFS(rx)[i].end + orig;
5885
5886                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5887                        parens that didn't match -- they should be set to
5888                        undef, not the empty string */
5889                     if (gimme_scalar) {
5890                         iters++;
5891                         if (m-s == 0)
5892                             trailing_empty++;
5893                         else
5894                             trailing_empty = 0;
5895                     } else {
5896                         if (m >= orig && s >= orig) {
5897                             dstr = newSVpvn_flags(s, m-s,
5898                                                  (do_utf8 ? SVf_UTF8 : 0)
5899                                                   | make_mortal);
5900                         }
5901                         else
5902                             dstr = &PL_sv_undef;  /* undef, not "" */
5903                         XPUSHs(dstr);
5904                     }
5905
5906                 }
5907             }
5908             s = RX_OFFS(rx)[0].end + orig;
5909         }
5910     }
5911
5912     if (!gimme_scalar) {
5913         iters = (SP - PL_stack_base) - base;
5914     }
5915     if (iters > maxiters)
5916         DIE(aTHX_ "Split loop");
5917
5918     /* keep field after final delim? */
5919     if (s < strend || (iters && origlimit)) {
5920         if (!gimme_scalar) {
5921             const STRLEN l = strend - s;
5922             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5923             XPUSHs(dstr);
5924         }
5925         iters++;
5926     }
5927     else if (!origlimit) {
5928         if (gimme_scalar) {
5929             iters -= trailing_empty;
5930         } else {
5931             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5932                 if (TOPs && !make_mortal)
5933                     sv_2mortal(TOPs);
5934                 *SP-- = &PL_sv_undef;
5935                 iters--;
5936             }
5937         }
5938     }
5939
5940     PUTBACK;
5941     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5942     SPAGAIN;
5943     if (realarray) {
5944         if (!mg) {
5945             if (SvSMAGICAL(ary)) {
5946                 PUTBACK;
5947                 mg_set(MUTABLE_SV(ary));
5948                 SPAGAIN;
5949             }
5950             if (gimme == G_ARRAY) {
5951                 EXTEND(SP, iters);
5952                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5953                 SP += iters;
5954                 RETURN;
5955             }
5956         }
5957         else {
5958             PUTBACK;
5959             ENTER_with_name("call_PUSH");
5960             call_method("PUSH",G_SCALAR|G_DISCARD);
5961             LEAVE_with_name("call_PUSH");
5962             SPAGAIN;
5963             if (gimme == G_ARRAY) {
5964                 I32 i;
5965                 /* EXTEND should not be needed - we just popped them */
5966                 EXTEND(SP, iters);
5967                 for (i=0; i < iters; i++) {
5968                     SV **svp = av_fetch(ary, i, FALSE);
5969                     PUSHs((svp) ? *svp : &PL_sv_undef);
5970                 }
5971                 RETURN;
5972             }
5973         }
5974     }
5975     else {
5976         if (gimme == G_ARRAY)
5977             RETURN;
5978     }
5979
5980     GETTARGET;
5981     PUSHi(iters);
5982     RETURN;
5983 }
5984
5985 PP(pp_once)
5986 {
5987     dSP;
5988     SV *const sv = PAD_SVl(PL_op->op_targ);
5989
5990     if (SvPADSTALE(sv)) {
5991         /* First time. */
5992         SvPADSTALE_off(sv);
5993         RETURNOP(cLOGOP->op_other);
5994     }
5995     RETURNOP(cLOGOP->op_next);
5996 }
5997
5998 PP(pp_lock)
5999 {
6000     dVAR;
6001     dSP;
6002     dTOPss;
6003     SV *retsv = sv;
6004     assert(SvTYPE(retsv) != SVt_PVCV);
6005     SvLOCK(sv);
6006     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6007         retsv = refto(retsv);
6008     }
6009     SETs(retsv);
6010     RETURN;
6011 }
6012
6013
6014 PP(unimplemented_op)
6015 {
6016     dVAR;
6017     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6018         PL_op->op_type);
6019 }
6020
6021 PP(pp_boolkeys)
6022 {
6023     dVAR;
6024     dSP;
6025     HV * const hv = (HV*)POPs;
6026
6027     if (SvRMAGICAL(hv)) {
6028         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6029         if (mg) {
6030             XPUSHs(magic_scalarpack(hv, mg));
6031             RETURN;
6032         }
6033     }
6034
6035     XPUSHs(boolSV(HvKEYS(hv) != 0));
6036     RETURN;
6037 }
6038
6039 /*
6040  * Local variables:
6041  * c-indentation-style: bsd
6042  * c-basic-offset: 4
6043  * indent-tabs-mode: t
6044  * End:
6045  *
6046  * ex: set ts=8 sts=4 sw=4 noet:
6047  */