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