pp.c

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