pp.c

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