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       if (left == 0.0 && right == 0.0)
2802           SETs(&PL_sv_undef);
2803       else
2804           SETn(Perl_atan2(left, right));
2805       RETURN;
2806     }
2807 }
2808
2809 PP(pp_sin)
2810 {
2811     dVAR; dSP; dTARGET;
2812     int amg_type = sin_amg;
2813     const char *neg_report = NULL;
2814     NV (*func)(NV) = Perl_sin;
2815     const int op_type = PL_op->op_type;
2816
2817     switch (op_type) {
2818     case OP_COS:
2819         amg_type = cos_amg;
2820         func = Perl_cos;
2821         break;
2822     case OP_EXP:
2823         amg_type = exp_amg;
2824         func = Perl_exp;
2825         break;
2826     case OP_LOG:
2827         amg_type = log_amg;
2828         func = Perl_log;
2829         neg_report = "log";
2830         break;
2831     case OP_SQRT:
2832         amg_type = sqrt_amg;
2833         func = Perl_sqrt;
2834         neg_report = "sqrt";
2835         break;
2836     }
2837
2838     tryAMAGICun_var(amg_type);
2839     {
2840       const NV value = POPn;
2841       if (neg_report) {
2842           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2843               SET_NUMERIC_STANDARD();
2844               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2845           }
2846       }
2847       XPUSHn(func(value));
2848       RETURN;
2849     }
2850 }
2851
2852 /* Support Configure command-line overrides for rand() functions.
2853    After 5.005, perhaps we should replace this by Configure support
2854    for drand48(), random(), or rand().  For 5.005, though, maintain
2855    compatibility by calling rand() but allow the user to override it.
2856    See INSTALL for details.  --Andy Dougherty  15 July 1998
2857 */
2858 /* Now it's after 5.005, and Configure supports drand48() and random(),
2859    in addition to rand().  So the overrides should not be needed any more.
2860    --Jarkko Hietaniemi  27 September 1998
2861  */
2862
2863 #ifndef HAS_DRAND48_PROTO
2864 extern double drand48 (void);
2865 #endif
2866
2867 PP(pp_rand)
2868 {
2869     dVAR; dSP; dTARGET;
2870     NV value;
2871     if (MAXARG < 1)
2872         value = 1.0;
2873     else
2874         value = POPn;
2875     if (value == 0.0)
2876         value = 1.0;
2877     if (!PL_srand_called) {
2878         (void)seedDrand01((Rand_seed_t)seed());
2879         PL_srand_called = TRUE;
2880     }
2881     value *= Drand01();
2882     XPUSHn(value);
2883     RETURN;
2884 }
2885
2886 PP(pp_srand)
2887 {
2888     dVAR; dSP;
2889     const UV anum = (MAXARG < 1) ? seed() : POPu;
2890     (void)seedDrand01((Rand_seed_t)anum);
2891     PL_srand_called = TRUE;
2892     EXTEND(SP, 1);
2893     RETPUSHYES;
2894 }
2895
2896 PP(pp_int)
2897 {
2898     dVAR; dSP; dTARGET; tryAMAGICun(int);
2899     {
2900       SV * const sv = sv_2num(TOPs);
2901       const IV iv = SvIV(sv);
2902       /* XXX it's arguable that compiler casting to IV might be subtly
2903          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2904          else preferring IV has introduced a subtle behaviour change bug. OTOH
2905          relying on floating point to be accurate is a bug.  */
2906
2907       if (!SvOK(sv)) {
2908         SETu(0);
2909       }
2910       else if (SvIOK(sv)) {
2911         if (SvIsUV(sv))
2912             SETu(SvUV(sv));
2913         else
2914             SETi(iv);
2915       }
2916       else {
2917           const NV value = SvNV(sv);
2918           if (value >= 0.0) {
2919               if (value < (NV)UV_MAX + 0.5) {
2920                   SETu(U_V(value));
2921               } else {
2922                   SETn(Perl_floor(value));
2923               }
2924           }
2925           else {
2926               if (value > (NV)IV_MIN - 0.5) {
2927                   SETi(I_V(value));
2928               } else {
2929                   SETn(Perl_ceil(value));
2930               }
2931           }
2932       }
2933     }
2934     RETURN;
2935 }
2936
2937 PP(pp_abs)
2938 {
2939     dVAR; dSP; dTARGET; tryAMAGICun(abs);
2940     {
2941       SV * const sv = sv_2num(TOPs);
2942       /* This will cache the NV value if string isn't actually integer  */
2943       const IV iv = SvIV(sv);
2944
2945       if (!SvOK(sv)) {
2946         SETu(0);
2947       }
2948       else if (SvIOK(sv)) {
2949         /* IVX is precise  */
2950         if (SvIsUV(sv)) {
2951           SETu(SvUV(sv));       /* force it to be numeric only */
2952         } else {
2953           if (iv >= 0) {
2954             SETi(iv);
2955           } else {
2956             if (iv != IV_MIN) {
2957               SETi(-iv);
2958             } else {
2959               /* 2s complement assumption. Also, not really needed as
2960                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2961               SETu(IV_MIN);
2962             }
2963           }
2964         }
2965       } else{
2966         const NV value = SvNV(sv);
2967         if (value < 0.0)
2968           SETn(-value);
2969         else
2970           SETn(value);
2971       }
2972     }
2973     RETURN;
2974 }
2975
2976 PP(pp_oct)
2977 {
2978     dVAR; dSP; dTARGET;
2979     const char *tmps;
2980     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2981     STRLEN len;
2982     NV result_nv;
2983     UV result_uv;
2984     SV* const sv = POPs;
2985
2986     tmps = (SvPV_const(sv, len));
2987     if (DO_UTF8(sv)) {
2988          /* If Unicode, try to downgrade
2989           * If not possible, croak. */
2990          SV* const tsv = sv_2mortal(newSVsv(sv));
2991
2992          SvUTF8_on(tsv);
2993          sv_utf8_downgrade(tsv, FALSE);
2994          tmps = SvPV_const(tsv, len);
2995     }
2996     if (PL_op->op_type == OP_HEX)
2997         goto hex;
2998
2999     while (*tmps && len && isSPACE(*tmps))
3000         tmps++, len--;
3001     if (*tmps == '0')
3002         tmps++, len--;
3003     if (*tmps == 'x') {
3004     hex:
3005         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3006     }
3007     else if (*tmps == 'b')
3008         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3009     else
3010         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3011
3012     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3013         XPUSHn(result_nv);
3014     }
3015     else {
3016         XPUSHu(result_uv);
3017     }
3018     RETURN;
3019 }
3020
3021 /* String stuff. */
3022
3023 PP(pp_length)
3024 {
3025     dVAR; dSP; dTARGET;
3026     SV * const sv = TOPs;
3027
3028     if (SvGAMAGIC(sv)) {
3029         /* For an overloaded or magic scalar, we can't know in advance if
3030            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3031            it likes to cache the length. Maybe that should be a documented
3032            feature of it.
3033         */
3034         STRLEN len;
3035         const char *const p
3036             = sv_2pv_flags(sv, &len,
3037                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3038
3039         if (!p)
3040             SETs(&PL_sv_undef);
3041         else if (DO_UTF8(sv)) {
3042             SETi(utf8_length((U8*)p, (U8*)p + len));
3043         }
3044         else
3045             SETi(len);
3046     } else if (SvOK(sv)) {
3047         /* Neither magic nor overloaded.  */
3048         if (DO_UTF8(sv))
3049             SETi(sv_len_utf8(sv));
3050         else
3051             SETi(sv_len(sv));
3052     } else {
3053         SETs(&PL_sv_undef);
3054     }
3055     RETURN;
3056 }
3057
3058 PP(pp_substr)
3059 {
3060     dVAR; dSP; dTARGET;
3061     SV *sv;
3062     I32 len = 0;
3063     STRLEN curlen;
3064     STRLEN utf8_curlen;
3065     I32 pos;
3066     I32 rem;
3067     I32 fail;
3068     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3069     const char *tmps;
3070     const I32 arybase = CopARYBASE_get(PL_curcop);
3071     SV *repl_sv = NULL;
3072     const char *repl = NULL;
3073     STRLEN repl_len;
3074     const int num_args = PL_op->op_private & 7;
3075     bool repl_need_utf8_upgrade = FALSE;
3076     bool repl_is_utf8 = FALSE;
3077
3078     SvTAINTED_off(TARG);                        /* decontaminate */
3079     SvUTF8_off(TARG);                           /* decontaminate */
3080     if (num_args > 2) {
3081         if (num_args > 3) {
3082             repl_sv = POPs;
3083             repl = SvPV_const(repl_sv, repl_len);
3084             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3085         }
3086         len = POPi;
3087     }
3088     pos = POPi;
3089     sv = POPs;
3090     PUTBACK;
3091     if (repl_sv) {
3092         if (repl_is_utf8) {
3093             if (!DO_UTF8(sv))
3094                 sv_utf8_upgrade(sv);
3095         }
3096         else if (DO_UTF8(sv))
3097             repl_need_utf8_upgrade = TRUE;
3098     }
3099     tmps = SvPV_const(sv, curlen);
3100     if (DO_UTF8(sv)) {
3101         utf8_curlen = sv_len_utf8(sv);
3102         if (utf8_curlen == curlen)
3103             utf8_curlen = 0;
3104         else
3105             curlen = utf8_curlen;
3106     }
3107     else
3108         utf8_curlen = 0;
3109
3110     if (pos >= arybase) {
3111         pos -= arybase;
3112         rem = curlen-pos;
3113         fail = rem;
3114         if (num_args > 2) {
3115             if (len < 0) {
3116                 rem += len;
3117                 if (rem < 0)
3118                     rem = 0;
3119             }
3120             else if (rem > len)
3121                      rem = len;
3122         }
3123     }
3124     else {
3125         pos += curlen;
3126         if (num_args < 3)
3127             rem = curlen;
3128         else if (len >= 0) {
3129             rem = pos+len;
3130             if (rem > (I32)curlen)
3131                 rem = curlen;
3132         }
3133         else {
3134             rem = curlen+len;
3135             if (rem < pos)
3136                 rem = pos;
3137         }
3138         if (pos < 0)
3139             pos = 0;
3140         fail = rem;
3141         rem -= pos;
3142     }
3143     if (fail < 0) {
3144         if (lvalue || repl)
3145             Perl_croak(aTHX_ "substr outside of string");
3146         if (ckWARN(WARN_SUBSTR))
3147             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3148         RETPUSHUNDEF;
3149     }
3150     else {
3151         const I32 upos = pos;
3152         const I32 urem = rem;
3153         if (utf8_curlen)
3154             sv_pos_u2b(sv, &pos, &rem);
3155         tmps += pos;
3156         /* we either return a PV or an LV. If the TARG hasn't been used
3157          * before, or is of that type, reuse it; otherwise use a mortal
3158          * instead. Note that LVs can have an extended lifetime, so also
3159          * dont reuse if refcount > 1 (bug #20933) */
3160         if (SvTYPE(TARG) > SVt_NULL) {
3161             if ( (SvTYPE(TARG) == SVt_PVLV)
3162                     ? (!lvalue || SvREFCNT(TARG) > 1)
3163                     : lvalue)
3164             {
3165                 TARG = sv_newmortal();
3166             }
3167         }
3168
3169         sv_setpvn(TARG, tmps, rem);
3170 #ifdef USE_LOCALE_COLLATE
3171         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3172 #endif
3173         if (utf8_curlen)
3174             SvUTF8_on(TARG);
3175         if (repl) {
3176             SV* repl_sv_copy = NULL;
3177
3178             if (repl_need_utf8_upgrade) {
3179                 repl_sv_copy = newSVsv(repl_sv);
3180                 sv_utf8_upgrade(repl_sv_copy);
3181                 repl = SvPV_const(repl_sv_copy, repl_len);
3182                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3183             }
3184             if (!SvOK(sv))
3185                 sv_setpvs(sv, "");
3186             sv_insert_flags(sv, pos, rem, repl, repl_len, 0);
3187             if (repl_is_utf8)
3188                 SvUTF8_on(sv);
3189             if (repl_sv_copy)
3190                 SvREFCNT_dec(repl_sv_copy);
3191         }
3192         else if (lvalue) {              /* it's an lvalue! */
3193             if (!SvGMAGICAL(sv)) {
3194                 if (SvROK(sv)) {
3195                     SvPV_force_nolen(sv);
3196                     if (ckWARN(WARN_SUBSTR))
3197                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3198                                 "Attempt to use reference as lvalue in substr");
3199                 }
3200                 if (isGV_with_GP(sv))
3201                     SvPV_force_nolen(sv);
3202                 else if (SvOK(sv))      /* is it defined ? */
3203                     (void)SvPOK_only_UTF8(sv);
3204                 else
3205                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3206             }
3207
3208             if (SvTYPE(TARG) < SVt_PVLV) {
3209                 sv_upgrade(TARG, SVt_PVLV);
3210                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3211             }
3212
3213             LvTYPE(TARG) = 'x';
3214             if (LvTARG(TARG) != sv) {
3215                 if (LvTARG(TARG))
3216                     SvREFCNT_dec(LvTARG(TARG));
3217                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3218             }
3219             LvTARGOFF(TARG) = upos;
3220             LvTARGLEN(TARG) = urem;
3221         }
3222     }
3223     SPAGAIN;
3224     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3225     RETURN;
3226 }
3227
3228 PP(pp_vec)
3229 {
3230     dVAR; dSP; dTARGET;
3231     register const IV size   = POPi;
3232     register const IV offset = POPi;
3233     register SV * const src = POPs;
3234     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3235
3236     SvTAINTED_off(TARG);                /* decontaminate */
3237     if (lvalue) {                       /* it's an lvalue! */
3238         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3239             TARG = sv_newmortal();
3240         if (SvTYPE(TARG) < SVt_PVLV) {
3241             sv_upgrade(TARG, SVt_PVLV);
3242             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3243         }
3244         LvTYPE(TARG) = 'v';
3245         if (LvTARG(TARG) != src) {
3246             if (LvTARG(TARG))
3247                 SvREFCNT_dec(LvTARG(TARG));
3248             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3249         }
3250         LvTARGOFF(TARG) = offset;
3251         LvTARGLEN(TARG) = size;
3252     }
3253
3254     sv_setuv(TARG, do_vecget(src, offset, size));
3255     PUSHs(TARG);
3256     RETURN;
3257 }
3258
3259 PP(pp_index)
3260 {
3261     dVAR; dSP; dTARGET;
3262     SV *big;
3263     SV *little;
3264     SV *temp = NULL;
3265     STRLEN biglen;
3266     STRLEN llen = 0;
3267     I32 offset;
3268     I32 retval;
3269     const char *big_p;
3270     const char *little_p;
3271     const I32 arybase = CopARYBASE_get(PL_curcop);
3272     bool big_utf8;
3273     bool little_utf8;
3274     const bool is_index = PL_op->op_type == OP_INDEX;
3275
3276     if (MAXARG >= 3) {
3277         /* arybase is in characters, like offset, so combine prior to the
3278            UTF-8 to bytes calculation.  */
3279         offset = POPi - arybase;
3280     }
3281     little = POPs;
3282     big = POPs;
3283     big_p = SvPV_const(big, biglen);
3284     little_p = SvPV_const(little, llen);
3285
3286     big_utf8 = DO_UTF8(big);
3287     little_utf8 = DO_UTF8(little);
3288     if (big_utf8 ^ little_utf8) {
3289         /* One needs to be upgraded.  */
3290         if (little_utf8 && !PL_encoding) {
3291             /* Well, maybe instead we might be able to downgrade the small
3292                string?  */
3293             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3294                                                      &little_utf8);
3295             if (little_utf8) {
3296                 /* If the large string is ISO-8859-1, and it's not possible to
3297                    convert the small string to ISO-8859-1, then there is no
3298                    way that it could be found anywhere by index.  */
3299                 retval = -1;
3300                 goto fail;
3301             }
3302
3303             /* At this point, pv is a malloc()ed string. So donate it to temp
3304                to ensure it will get free()d  */
3305             little = temp = newSV(0);
3306             sv_usepvn(temp, pv, llen);
3307             little_p = SvPVX(little);
3308         } else {
3309             temp = little_utf8
3310                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3311
3312             if (PL_encoding) {
3313                 sv_recode_to_utf8(temp, PL_encoding);
3314             } else {
3315                 sv_utf8_upgrade(temp);
3316             }
3317             if (little_utf8) {
3318                 big = temp;
3319                 big_utf8 = TRUE;
3320                 big_p = SvPV_const(big, biglen);
3321             } else {
3322                 little = temp;
3323                 little_p = SvPV_const(little, llen);
3324             }
3325         }
3326     }
3327     if (SvGAMAGIC(big)) {
3328         /* Life just becomes a lot easier if I use a temporary here.
3329            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3330            will trigger magic and overloading again, as will fbm_instr()
3331         */
3332         big = newSVpvn_flags(big_p, biglen,
3333                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3334         big_p = SvPVX(big);
3335     }
3336     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3337         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3338            warn on undef, and we've already triggered a warning with the
3339            SvPV_const some lines above. We can't remove that, as we need to
3340            call some SvPV to trigger overloading early and find out if the
3341            string is UTF-8.
3342            This is all getting to messy. The API isn't quite clean enough,
3343            because data access has side effects.
3344         */
3345         little = newSVpvn_flags(little_p, llen,
3346                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3347         little_p = SvPVX(little);
3348     }
3349
3350     if (MAXARG < 3)
3351         offset = is_index ? 0 : biglen;
3352     else {
3353         if (big_utf8 && offset > 0)
3354             sv_pos_u2b(big, &offset, 0);
3355         if (!is_index)
3356             offset += llen;
3357     }
3358     if (offset < 0)
3359         offset = 0;
3360     else if (offset > (I32)biglen)
3361         offset = biglen;
3362     if (!(little_p = is_index
3363           ? fbm_instr((unsigned char*)big_p + offset,
3364                       (unsigned char*)big_p + biglen, little, 0)
3365           : rninstr(big_p,  big_p  + offset,
3366                     little_p, little_p + llen)))
3367         retval = -1;
3368     else {
3369         retval = little_p - big_p;
3370         if (retval > 0 && big_utf8)
3371             sv_pos_b2u(big, &retval);
3372     }
3373     if (temp)
3374         SvREFCNT_dec(temp);
3375  fail:
3376     PUSHi(retval + arybase);
3377     RETURN;
3378 }
3379
3380 PP(pp_sprintf)
3381 {
3382     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3383     if (SvTAINTED(MARK[1]))
3384         TAINT_PROPER("sprintf");
3385     do_sprintf(TARG, SP-MARK, MARK+1);
3386     TAINT_IF(SvTAINTED(TARG));
3387     SP = ORIGMARK;
3388     PUSHTARG;
3389     RETURN;
3390 }
3391
3392 PP(pp_ord)
3393 {
3394     dVAR; dSP; dTARGET;
3395
3396     SV *argsv = POPs;
3397     STRLEN len;
3398     const U8 *s = (U8*)SvPV_const(argsv, len);
3399
3400     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3401         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3402         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3403         argsv = tmpsv;
3404     }
3405
3406     XPUSHu(DO_UTF8(argsv) ?
3407            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3408            (UV)(*s & 0xff));
3409
3410     RETURN;
3411 }
3412
3413 PP(pp_chr)
3414 {
3415     dVAR; dSP; dTARGET;
3416     char *tmps;
3417     UV value;
3418
3419     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3420          ||
3421          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3422         if (IN_BYTES) {
3423             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3424         } else {
3425             (void) POPs; /* Ignore the argument value. */
3426             value = UNICODE_REPLACEMENT;
3427         }
3428     } else {
3429         value = POPu;
3430     }
3431
3432     SvUPGRADE(TARG,SVt_PV);
3433
3434     if (value > 255 && !IN_BYTES) {
3435         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3436         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3437         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3438         *tmps = '\0';
3439         (void)SvPOK_only(TARG);
3440         SvUTF8_on(TARG);
3441         XPUSHs(TARG);
3442         RETURN;
3443     }
3444
3445     SvGROW(TARG,2);
3446     SvCUR_set(TARG, 1);
3447     tmps = SvPVX(TARG);
3448     *tmps++ = (char)value;
3449     *tmps = '\0';
3450     (void)SvPOK_only(TARG);
3451
3452     if (PL_encoding && !IN_BYTES) {
3453         sv_recode_to_utf8(TARG, PL_encoding);
3454         tmps = SvPVX(TARG);
3455         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3456             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3457             SvGROW(TARG, 2);
3458             tmps = SvPVX(TARG);
3459             SvCUR_set(TARG, 1);
3460             *tmps++ = (char)value;
3461             *tmps = '\0';
3462             SvUTF8_off(TARG);
3463         }
3464     }
3465
3466     XPUSHs(TARG);
3467     RETURN;
3468 }
3469
3470 PP(pp_crypt)
3471 {
3472 #ifdef HAS_CRYPT
3473     dVAR; dSP; dTARGET;
3474     dPOPTOPssrl;
3475     STRLEN len;
3476     const char *tmps = SvPV_const(left, len);
3477
3478     if (DO_UTF8(left)) {
3479          /* If Unicode, try to downgrade.
3480           * If not possible, croak.
3481           * Yes, we made this up.  */
3482          SV* const tsv = sv_2mortal(newSVsv(left));
3483
3484          SvUTF8_on(tsv);
3485          sv_utf8_downgrade(tsv, FALSE);
3486          tmps = SvPV_const(tsv, len);
3487     }
3488 #   ifdef USE_ITHREADS
3489 #     ifdef HAS_CRYPT_R
3490     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3491       /* This should be threadsafe because in ithreads there is only
3492        * one thread per interpreter.  If this would not be true,
3493        * we would need a mutex to protect this malloc. */
3494         PL_reentrant_buffer->_crypt_struct_buffer =
3495           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3496 #if defined(__GLIBC__) || defined(__EMX__)
3497         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3498             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3499             /* work around glibc-2.2.5 bug */
3500             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3501         }
3502 #endif
3503     }
3504 #     endif /* HAS_CRYPT_R */
3505 #   endif /* USE_ITHREADS */
3506 #   ifdef FCRYPT
3507     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3508 #   else
3509     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3510 #   endif
3511     SETs(TARG);
3512     RETURN;
3513 #else
3514     DIE(aTHX_
3515       "The crypt() function is unimplemented due to excessive paranoia.");
3516 #endif
3517 }
3518
3519 PP(pp_ucfirst)
3520 {
3521     dVAR;
3522     dSP;
3523     SV *source = TOPs;
3524     STRLEN slen;
3525     STRLEN need;
3526     SV *dest;
3527     bool inplace = TRUE;
3528     bool doing_utf8;
3529     const int op_type = PL_op->op_type;
3530     const U8 *s;
3531     U8 *d;
3532     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3533     STRLEN ulen;
3534     STRLEN tculen;
3535
3536     SvGETMAGIC(source);
3537     if (SvOK(source)) {
3538         s = (const U8*)SvPV_nomg_const(source, slen);
3539     } else {
3540         if (ckWARN(WARN_UNINITIALIZED))
3541             report_uninit(source);
3542         s = (const U8*)"";
3543         slen = 0;
3544     }
3545
3546     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3547         doing_utf8 = TRUE;
3548         utf8_to_uvchr(s, &ulen);
3549         if (op_type == OP_UCFIRST) {
3550             toTITLE_utf8(s, tmpbuf, &tculen);
3551         } else {
3552             toLOWER_utf8(s, tmpbuf, &tculen);
3553         }
3554         /* If the two differ, we definately cannot do inplace.  */
3555         inplace = (ulen == tculen);
3556         need = slen + 1 - ulen + tculen;
3557     } else {
3558         doing_utf8 = FALSE;
3559         need = slen + 1;
3560     }
3561
3562     if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3563         /* We can convert in place.  */
3564
3565         dest = source;
3566         s = d = (U8*)SvPV_force_nomg(source, slen);
3567     } else {
3568         dTARGET;
3569
3570         dest = TARG;
3571
3572         SvUPGRADE(dest, SVt_PV);
3573         d = (U8*)SvGROW(dest, need);
3574         (void)SvPOK_only(dest);
3575
3576         SETs(dest);
3577
3578         inplace = FALSE;
3579     }
3580
3581     if (doing_utf8) {
3582         if(!inplace) {
3583             /* slen is the byte length of the whole SV.
3584              * ulen is the byte length of the original Unicode character
3585              * stored as UTF-8 at s.
3586              * tculen is the byte length of the freshly titlecased (or
3587              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3588              * We first set the result to be the titlecased (/lowercased)
3589              * character, and then append the rest of the SV data. */
3590             sv_setpvn(dest, (char*)tmpbuf, tculen);
3591             if (slen > ulen)
3592                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3593             SvUTF8_on(dest);
3594         }
3595         else {
3596             Copy(tmpbuf, d, tculen, U8);
3597             SvCUR_set(dest, need - 1);
3598         }
3599     }
3600     else {
3601         if (*s) {
3602             if (IN_LOCALE_RUNTIME) {
3603                 TAINT;
3604                 SvTAINTED_on(dest);
3605                 *d = (op_type == OP_UCFIRST)
3606                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3607             }
3608             else
3609                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3610         } else {
3611             /* See bug #39028  */
3612             *d = *s;
3613         }
3614
3615         if (SvUTF8(source))
3616             SvUTF8_on(dest);
3617
3618         if (!inplace) {
3619             /* This will copy the trailing NUL  */
3620             Copy(s + 1, d + 1, slen, U8);
3621             SvCUR_set(dest, need - 1);
3622         }
3623     }
3624     SvSETMAGIC(dest);
3625     RETURN;
3626 }
3627
3628 /* There's so much setup/teardown code common between uc and lc, I wonder if
3629    it would be worth merging the two, and just having a switch outside each
3630    of the three tight loops.  */
3631 PP(pp_uc)
3632 {
3633     dVAR;
3634     dSP;
3635     SV *source = TOPs;
3636     STRLEN len;
3637     STRLEN min;
3638     SV *dest;
3639     const U8 *s;
3640     U8 *d;
3641
3642     SvGETMAGIC(source);
3643
3644     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3645         && SvTEMP(source) && !DO_UTF8(source)) {
3646         /* We can convert in place.  */
3647
3648         dest = source;
3649         s = d = (U8*)SvPV_force_nomg(source, len);
3650         min = len + 1;
3651     } else {
3652         dTARGET;
3653
3654         dest = TARG;
3655
3656         /* The old implementation would copy source into TARG at this point.
3657            This had the side effect that if source was undef, TARG was now
3658            an undefined SV with PADTMP set, and they don't warn inside
3659            sv_2pv_flags(). However, we're now getting the PV direct from
3660            source, which doesn't have PADTMP set, so it would warn. Hence the
3661            little games.  */
3662
3663         if (SvOK(source)) {
3664             s = (const U8*)SvPV_nomg_const(source, len);
3665         } else {
3666             if (ckWARN(WARN_UNINITIALIZED))
3667                 report_uninit(source);
3668             s = (const U8*)"";
3669             len = 0;
3670         }
3671         min = len + 1;
3672
3673         SvUPGRADE(dest, SVt_PV);
3674         d = (U8*)SvGROW(dest, min);
3675         (void)SvPOK_only(dest);
3676
3677         SETs(dest);
3678     }
3679
3680     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3681        to check DO_UTF8 again here.  */
3682
3683     if (DO_UTF8(source)) {
3684         const U8 *const send = s + len;
3685         U8 tmpbuf[UTF8_MAXBYTES+1];
3686
3687         while (s < send) {
3688             const STRLEN u = UTF8SKIP(s);
3689             STRLEN ulen;
3690
3691             toUPPER_utf8(s, tmpbuf, &ulen);
3692             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3693                 /* If the eventually required minimum size outgrows
3694                  * the available space, we need to grow. */
3695                 const UV o = d - (U8*)SvPVX_const(dest);
3696
3697                 /* If someone uppercases one million U+03B0s we SvGROW() one
3698                  * million times.  Or we could try guessing how much to
3699                  allocate without allocating too much.  Such is life. */
3700                 SvGROW(dest, min);
3701                 d = (U8*)SvPVX(dest) + o;
3702             }
3703             Copy(tmpbuf, d, ulen, U8);
3704             d += ulen;
3705             s += u;
3706         }
3707         SvUTF8_on(dest);
3708         *d = '\0';
3709         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3710     } else {
3711         if (len) {
3712             const U8 *const send = s + len;
3713             if (IN_LOCALE_RUNTIME) {
3714                 TAINT;
3715                 SvTAINTED_on(dest);
3716                 for (; s < send; d++, s++)
3717                     *d = toUPPER_LC(*s);
3718             }
3719             else {
3720                 for (; s < send; d++, s++)
3721                     *d = toUPPER(*s);
3722             }
3723         }
3724         if (source != dest) {
3725             *d = '\0';
3726             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3727         }
3728     }
3729     SvSETMAGIC(dest);
3730     RETURN;
3731 }
3732
3733 PP(pp_lc)
3734 {
3735     dVAR;
3736     dSP;
3737     SV *source = TOPs;
3738     STRLEN len;
3739     STRLEN min;
3740     SV *dest;
3741     const U8 *s;
3742     U8 *d;
3743
3744     SvGETMAGIC(source);
3745
3746     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3747         && SvTEMP(source) && !DO_UTF8(source)) {
3748         /* We can convert in place.  */
3749
3750         dest = source;
3751         s = d = (U8*)SvPV_force_nomg(source, len);
3752         min = len + 1;
3753     } else {
3754         dTARGET;
3755
3756         dest = TARG;
3757
3758         /* The old implementation would copy source into TARG at this point.
3759            This had the side effect that if source was undef, TARG was now
3760            an undefined SV with PADTMP set, and they don't warn inside
3761            sv_2pv_flags(). However, we're now getting the PV direct from
3762            source, which doesn't have PADTMP set, so it would warn. Hence the
3763            little games.  */
3764
3765         if (SvOK(source)) {
3766             s = (const U8*)SvPV_nomg_const(source, len);
3767         } else {
3768             if (ckWARN(WARN_UNINITIALIZED))
3769                 report_uninit(source);
3770             s = (const U8*)"";
3771             len = 0;
3772         }
3773         min = len + 1;
3774
3775         SvUPGRADE(dest, SVt_PV);
3776         d = (U8*)SvGROW(dest, min);
3777         (void)SvPOK_only(dest);
3778
3779         SETs(dest);
3780     }
3781
3782     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3783        to check DO_UTF8 again here.  */
3784
3785     if (DO_UTF8(source)) {
3786         const U8 *const send = s + len;
3787         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3788
3789         while (s < send) {
3790             const STRLEN u = UTF8SKIP(s);
3791             STRLEN ulen;
3792             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3793
3794 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3795             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3796                 NOOP;
3797                 /*
3798                  * Now if the sigma is NOT followed by
3799                  * /$ignorable_sequence$cased_letter/;
3800                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3801                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3802                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3803                  * then it should be mapped to 0x03C2,
3804                  * (GREEK SMALL LETTER FINAL SIGMA),
3805                  * instead of staying 0x03A3.
3806                  * "should be": in other words, this is not implemented yet.
3807                  * See lib/unicore/SpecialCasing.txt.
3808                  */
3809             }
3810             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3811                 /* If the eventually required minimum size outgrows
3812                  * the available space, we need to grow. */
3813                 const UV o = d - (U8*)SvPVX_const(dest);
3814
3815                 /* If someone lowercases one million U+0130s we SvGROW() one
3816                  * million times.  Or we could try guessing how much to
3817                  allocate without allocating too much.  Such is life. */
3818                 SvGROW(dest, min);
3819                 d = (U8*)SvPVX(dest) + o;
3820             }
3821             Copy(tmpbuf, d, ulen, U8);
3822             d += ulen;
3823             s += u;
3824         }
3825         SvUTF8_on(dest);
3826         *d = '\0';
3827         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3828     } else {
3829         if (len) {
3830             const U8 *const send = s + len;
3831             if (IN_LOCALE_RUNTIME) {
3832                 TAINT;
3833                 SvTAINTED_on(dest);
3834                 for (; s < send; d++, s++)
3835                     *d = toLOWER_LC(*s);
3836             }
3837             else {
3838                 for (; s < send; d++, s++)
3839                     *d = toLOWER(*s);
3840             }
3841         }
3842         if (source != dest) {
3843             *d = '\0';
3844             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3845         }
3846     }
3847     SvSETMAGIC(dest);
3848     RETURN;
3849 }
3850
3851 PP(pp_quotemeta)
3852 {
3853     dVAR; dSP; dTARGET;
3854     SV * const sv = TOPs;
3855     STRLEN len;
3856     register const char *s = SvPV_const(sv,len);
3857
3858     SvUTF8_off(TARG);                           /* decontaminate */
3859     if (len) {
3860         register char *d;
3861         SvUPGRADE(TARG, SVt_PV);
3862         SvGROW(TARG, (len * 2) + 1);
3863         d = SvPVX(TARG);
3864         if (DO_UTF8(sv)) {
3865             while (len) {
3866                 if (UTF8_IS_CONTINUED(*s)) {
3867                     STRLEN ulen = UTF8SKIP(s);
3868                     if (ulen > len)
3869                         ulen = len;
3870                     len -= ulen;
3871                     while (ulen--)
3872                         *d++ = *s++;
3873                 }
3874                 else {
3875                     if (!isALNUM(*s))
3876                         *d++ = '\\';
3877                     *d++ = *s++;
3878                     len--;
3879                 }
3880             }
3881             SvUTF8_on(TARG);
3882         }
3883         else {
3884             while (len--) {
3885                 if (!isALNUM(*s))
3886                     *d++ = '\\';
3887                 *d++ = *s++;
3888             }
3889         }
3890         *d = '\0';
3891         SvCUR_set(TARG, d - SvPVX_const(TARG));
3892         (void)SvPOK_only_UTF8(TARG);
3893     }
3894     else
3895         sv_setpvn(TARG, s, len);
3896     SETs(TARG);
3897     if (SvSMAGICAL(TARG))
3898         mg_set(TARG);
3899     RETURN;
3900 }
3901
3902 /* Arrays. */
3903
3904 PP(pp_aslice)
3905 {
3906     dVAR; dSP; dMARK; dORIGMARK;
3907     register AV* const av = (AV*)POPs;
3908     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3909
3910     if (SvTYPE(av) == SVt_PVAV) {
3911         const I32 arybase = CopARYBASE_get(PL_curcop);
3912         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3913             register SV **svp;
3914             I32 max = -1;
3915             for (svp = MARK + 1; svp <= SP; svp++) {
3916                 const I32 elem = SvIV(*svp);
3917                 if (elem > max)
3918                     max = elem;
3919             }
3920             if (max > AvMAX(av))
3921                 av_extend(av, max);
3922         }
3923         while (++MARK <= SP) {
3924             register SV **svp;
3925             I32 elem = SvIV(*MARK);
3926
3927             if (elem > 0)
3928                 elem -= arybase;
3929             svp = av_fetch(av, elem, lval);
3930             if (lval) {
3931                 if (!svp || *svp == &PL_sv_undef)
3932                     DIE(aTHX_ PL_no_aelem, elem);
3933                 if (PL_op->op_private & OPpLVAL_INTRO)
3934                     save_aelem(av, elem, svp);
3935             }
3936             *MARK = svp ? *svp : &PL_sv_undef;
3937         }
3938     }
3939     if (GIMME != G_ARRAY) {
3940         MARK = ORIGMARK;
3941         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3942         SP = MARK;
3943     }
3944     RETURN;
3945 }
3946
3947 PP(pp_aeach)
3948 {
3949     dVAR;
3950     dSP;
3951     AV *array = (AV*)POPs;
3952     const I32 gimme = GIMME_V;
3953     IV *iterp = Perl_av_iter_p(aTHX_ array);
3954     const IV current = (*iterp)++;
3955
3956     if (current > av_len(array)) {
3957         *iterp = 0;
3958         if (gimme == G_SCALAR)
3959             RETPUSHUNDEF;
3960         else
3961             RETURN;
3962     }
3963
3964     EXTEND(SP, 2);
3965     mPUSHi(CopARYBASE_get(PL_curcop) + current);
3966     if (gimme == G_ARRAY) {
3967         SV **const element = av_fetch(array, current, 0);
3968         PUSHs(element ? *element : &PL_sv_undef);
3969     }
3970     RETURN;
3971 }
3972
3973 PP(pp_akeys)
3974 {
3975     dVAR;
3976     dSP;
3977     AV *array = (AV*)POPs;
3978     const I32 gimme = GIMME_V;
3979
3980     *Perl_av_iter_p(aTHX_ array) = 0;
3981
3982     if (gimme == G_SCALAR) {
3983         dTARGET;
3984         PUSHi(av_len(array) + 1);
3985     }
3986     else if (gimme == G_ARRAY) {
3987         IV n = Perl_av_len(aTHX_ array);
3988         IV i = CopARYBASE_get(PL_curcop);
3989
3990         EXTEND(SP, n + 1);
3991
3992         if (PL_op->op_type == OP_AKEYS) {
3993             n += i;
3994             for (;  i <= n;  i++) {
3995                 mPUSHi(i);
3996             }
3997         }
3998         else {
3999             for (i = 0;  i <= n;  i++) {
4000                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4001                 PUSHs(elem ? *elem : &PL_sv_undef);
4002             }
4003         }
4004     }
4005     RETURN;
4006 }
4007
4008 /* Associative arrays. */
4009
4010 PP(pp_each)
4011 {
4012     dVAR;
4013     dSP;
4014     HV * hash = (HV*)POPs;
4015     HE *entry;
4016     const I32 gimme = GIMME_V;
4017
4018     PUTBACK;
4019     /* might clobber stack_sp */
4020     entry = hv_iternext(hash);
4021     SPAGAIN;
4022
4023     EXTEND(SP, 2);
4024     if (entry) {
4025         SV* const sv = hv_iterkeysv(entry);
4026         PUSHs(sv);      /* won't clobber stack_sp */
4027         if (gimme == G_ARRAY) {
4028             SV *val;
4029             PUTBACK;
4030             /* might clobber stack_sp */
4031             val = hv_iterval(hash, entry);
4032             SPAGAIN;
4033             PUSHs(val);
4034         }
4035     }
4036     else if (gimme == G_SCALAR)
4037         RETPUSHUNDEF;
4038
4039     RETURN;
4040 }
4041
4042 PP(pp_delete)
4043 {
4044     dVAR;
4045     dSP;
4046     const I32 gimme = GIMME_V;
4047     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4048
4049     if (PL_op->op_private & OPpSLICE) {
4050         dMARK; dORIGMARK;
4051         HV * const hv = (HV*)POPs;
4052         const U32 hvtype = SvTYPE(hv);
4053         if (hvtype == SVt_PVHV) {                       /* hash element */
4054             while (++MARK <= SP) {
4055                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4056                 *MARK = sv ? sv : &PL_sv_undef;
4057             }
4058         }
4059         else if (hvtype == SVt_PVAV) {                  /* array element */
4060             if (PL_op->op_flags & OPf_SPECIAL) {
4061                 while (++MARK <= SP) {
4062                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
4063                     *MARK = sv ? sv : &PL_sv_undef;
4064                 }
4065             }
4066         }
4067         else
4068             DIE(aTHX_ "Not a HASH reference");
4069         if (discard)
4070             SP = ORIGMARK;
4071         else if (gimme == G_SCALAR) {
4072             MARK = ORIGMARK;
4073             if (SP > MARK)
4074                 *++MARK = *SP;
4075             else
4076                 *++MARK = &PL_sv_undef;
4077             SP = MARK;
4078         }
4079     }
4080     else {
4081         SV *keysv = POPs;
4082         HV * const hv = (HV*)POPs;
4083         SV *sv;
4084         if (SvTYPE(hv) == SVt_PVHV)
4085             sv = hv_delete_ent(hv, keysv, discard, 0);
4086         else if (SvTYPE(hv) == SVt_PVAV) {
4087             if (PL_op->op_flags & OPf_SPECIAL)
4088                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
4089             else
4090                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4091         }
4092         else
4093             DIE(aTHX_ "Not a HASH reference");
4094         if (!sv)
4095             sv = &PL_sv_undef;
4096         if (!discard)
4097             PUSHs(sv);
4098     }
4099     RETURN;
4100 }
4101
4102 PP(pp_exists)
4103 {
4104     dVAR;
4105     dSP;
4106     SV *tmpsv;
4107     HV *hv;
4108
4109     if (PL_op->op_private & OPpEXISTS_SUB) {
4110         GV *gv;
4111         SV * const sv = POPs;
4112         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4113         if (cv)
4114             RETPUSHYES;
4115         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4116             RETPUSHYES;
4117         RETPUSHNO;
4118     }
4119     tmpsv = POPs;
4120     hv = (HV*)POPs;
4121     if (SvTYPE(hv) == SVt_PVHV) {
4122         if (hv_exists_ent(hv, tmpsv, 0))
4123             RETPUSHYES;
4124     }
4125     else if (SvTYPE(hv) == SVt_PVAV) {
4126         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4127             if (av_exists((AV*)hv, SvIV(tmpsv)))
4128                 RETPUSHYES;
4129         }
4130     }
4131     else {
4132         DIE(aTHX_ "Not a HASH reference");
4133     }
4134     RETPUSHNO;
4135 }
4136
4137 PP(pp_hslice)
4138 {
4139     dVAR; dSP; dMARK; dORIGMARK;
4140     register HV * const hv = (HV*)POPs;
4141     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4142     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4143     bool other_magic = FALSE;
4144
4145     if (localizing) {
4146         MAGIC *mg;
4147         HV *stash;
4148
4149         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4150             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4151              /* Try to preserve the existenceness of a tied hash
4152               * element by using EXISTS and DELETE if possible.
4153               * Fallback to FETCH and STORE otherwise */
4154              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4155              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4156              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4157     }
4158
4159     while (++MARK <= SP) {
4160         SV * const keysv = *MARK;
4161         SV **svp;
4162         HE *he;
4163         bool preeminent = FALSE;
4164
4165         if (localizing) {
4166             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4167                 hv_exists_ent(hv, keysv, 0);
4168         }
4169
4170         he = hv_fetch_ent(hv, keysv, lval, 0);
4171         svp = he ? &HeVAL(he) : NULL;
4172
4173         if (lval) {
4174             if (!svp || *svp == &PL_sv_undef) {
4175                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4176             }
4177             if (localizing) {
4178                 if (HvNAME_get(hv) && isGV(*svp))
4179                     save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
4180                 else {
4181                     if (preeminent)
4182                         save_helem(hv, keysv, svp);
4183                     else {
4184                         STRLEN keylen;
4185                         const char * const key = SvPV_const(keysv, keylen);
4186                         SAVEDELETE(hv, savepvn(key,keylen),
4187                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
4188                     }
4189                 }
4190             }
4191         }
4192         *MARK = svp ? *svp : &PL_sv_undef;
4193     }
4194     if (GIMME != G_ARRAY) {
4195         MARK = ORIGMARK;
4196         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4197         SP = MARK;
4198     }
4199     RETURN;
4200 }
4201
4202 /* List operators. */
4203
4204 PP(pp_list)
4205 {
4206     dVAR; dSP; dMARK;
4207     if (GIMME != G_ARRAY) {
4208         if (++MARK <= SP)
4209             *MARK = *SP;                /* unwanted list, return last item */
4210         else
4211             *MARK = &PL_sv_undef;
4212         SP = MARK;
4213     }
4214     RETURN;
4215 }
4216
4217 PP(pp_lslice)
4218 {
4219     dVAR;
4220     dSP;
4221     SV ** const lastrelem = PL_stack_sp;
4222     SV ** const lastlelem = PL_stack_base + POPMARK;
4223     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4224     register SV ** const firstrelem = lastlelem + 1;
4225     const I32 arybase = CopARYBASE_get(PL_curcop);
4226     I32 is_something_there = FALSE;
4227
4228     register const I32 max = lastrelem - lastlelem;
4229     register SV **lelem;
4230
4231     if (GIMME != G_ARRAY) {
4232         I32 ix = SvIV(*lastlelem);
4233         if (ix < 0)
4234             ix += max;
4235         else
4236             ix -= arybase;
4237         if (ix < 0 || ix >= max)
4238             *firstlelem = &PL_sv_undef;
4239         else
4240             *firstlelem = firstrelem[ix];
4241         SP = firstlelem;
4242         RETURN;
4243     }
4244
4245     if (max == 0) {
4246         SP = firstlelem - 1;
4247         RETURN;
4248     }
4249
4250     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4251         I32 ix = SvIV(*lelem);
4252         if (ix < 0)
4253             ix += max;
4254         else
4255             ix -= arybase;
4256         if (ix < 0 || ix >= max)
4257             *lelem = &PL_sv_undef;
4258         else {
4259             is_something_there = TRUE;
4260             if (!(*lelem = firstrelem[ix]))
4261                 *lelem = &PL_sv_undef;
4262         }
4263     }
4264     if (is_something_there)
4265         SP = lastlelem;
4266     else
4267         SP = firstlelem - 1;
4268     RETURN;
4269 }
4270
4271 PP(pp_anonlist)
4272 {
4273     dVAR; dSP; dMARK; dORIGMARK;
4274     const I32 items = SP - MARK;
4275     SV * const av = (SV *) av_make(items, MARK+1);
4276     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4277     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4278             ? newRV_noinc(av) : av);
4279     RETURN;
4280 }
4281
4282 PP(pp_anonhash)
4283 {
4284     dVAR; dSP; dMARK; dORIGMARK;
4285     HV* const hv = newHV();
4286
4287     while (MARK < SP) {
4288         SV * const key = *++MARK;
4289         SV * const val = newSV(0);
4290         if (MARK < SP)
4291             sv_setsv(val, *++MARK);
4292         else if (ckWARN(WARN_MISC))
4293             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4294         (void)hv_store_ent(hv,key,val,0);
4295     }
4296     SP = ORIGMARK;
4297     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4298             ? newRV_noinc((SV*) hv) : (SV*) hv);
4299     RETURN;
4300 }
4301
4302 PP(pp_splice)
4303 {
4304     dVAR; dSP; dMARK; dORIGMARK;
4305     register AV *ary = (AV*)*++MARK;
4306     register SV **src;
4307     register SV **dst;
4308     register I32 i;
4309     register I32 offset;
4310     register I32 length;
4311     I32 newlen;
4312     I32 after;
4313     I32 diff;
4314     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4315
4316     if (mg) {
4317         *MARK-- = SvTIED_obj((SV*)ary, mg);
4318         PUSHMARK(MARK);
4319         PUTBACK;
4320         ENTER;
4321         call_method("SPLICE",GIMME_V);
4322         LEAVE;
4323         SPAGAIN;
4324         RETURN;
4325     }
4326
4327     SP++;
4328
4329     if (++MARK < SP) {
4330         offset = i = SvIV(*MARK);
4331         if (offset < 0)
4332             offset += AvFILLp(ary) + 1;
4333         else
4334             offset -= CopARYBASE_get(PL_curcop);
4335         if (offset < 0)
4336             DIE(aTHX_ PL_no_aelem, i);
4337         if (++MARK < SP) {
4338             length = SvIVx(*MARK++);
4339             if (length < 0) {
4340                 length += AvFILLp(ary) - offset + 1;
4341                 if (length < 0)
4342                     length = 0;
4343             }
4344         }
4345         else
4346             length = AvMAX(ary) + 1;            /* close enough to infinity */
4347     }
4348     else {
4349         offset = 0;
4350         length = AvMAX(ary) + 1;
4351     }
4352     if (offset > AvFILLp(ary) + 1) {
4353         if (ckWARN(WARN_MISC))
4354             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4355         offset = AvFILLp(ary) + 1;
4356     }
4357     after = AvFILLp(ary) + 1 - (offset + length);
4358     if (after < 0) {                            /* not that much array */
4359         length += after;                        /* offset+length now in array */
4360         after = 0;
4361         if (!AvALLOC(ary))
4362             av_extend(ary, 0);
4363     }
4364
4365     /* At this point, MARK .. SP-1 is our new LIST */
4366
4367     newlen = SP - MARK;
4368     diff = newlen - length;
4369     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4370         av_reify(ary);
4371
4372     /* make new elements SVs now: avoid problems if they're from the array */
4373     for (dst = MARK, i = newlen; i; i--) {
4374         SV * const h = *dst;
4375         *dst++ = newSVsv(h);
4376     }
4377
4378     if (diff < 0) {                             /* shrinking the area */
4379         SV **tmparyval = NULL;
4380         if (newlen) {
4381             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4382             Copy(MARK, tmparyval, newlen, SV*);
4383         }
4384
4385         MARK = ORIGMARK + 1;
4386         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4387             MEXTEND(MARK, length);
4388             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4389             if (AvREAL(ary)) {
4390                 EXTEND_MORTAL(length);
4391                 for (i = length, dst = MARK; i; i--) {
4392                     sv_2mortal(*dst);   /* free them eventualy */
4393                     dst++;
4394                 }
4395             }
4396             MARK += length - 1;
4397         }
4398         else {
4399             *MARK = AvARRAY(ary)[offset+length-1];
4400             if (AvREAL(ary)) {
4401                 sv_2mortal(*MARK);
4402                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4403                     SvREFCNT_dec(*dst++);       /* free them now */
4404             }
4405         }
4406         AvFILLp(ary) += diff;
4407
4408         /* pull up or down? */
4409
4410         if (offset < after) {                   /* easier to pull up */
4411             if (offset) {                       /* esp. if nothing to pull */
4412                 src = &AvARRAY(ary)[offset-1];
4413                 dst = src - diff;               /* diff is negative */
4414                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4415                     *dst-- = *src--;
4416             }
4417             dst = AvARRAY(ary);
4418             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4419             AvMAX(ary) += diff;
4420         }
4421         else {
4422             if (after) {                        /* anything to pull down? */
4423                 src = AvARRAY(ary) + offset + length;
4424                 dst = src + diff;               /* diff is negative */
4425                 Move(src, dst, after, SV*);
4426             }
4427             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4428                                                 /* avoid later double free */
4429         }
4430         i = -diff;
4431         while (i)
4432             dst[--i] = &PL_sv_undef;
4433
4434         if (newlen) {
4435             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4436             Safefree(tmparyval);
4437         }
4438     }
4439     else {                                      /* no, expanding (or same) */
4440         SV** tmparyval = NULL;
4441         if (length) {
4442             Newx(tmparyval, length, SV*);       /* so remember deletion */
4443             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4444         }
4445
4446         if (diff > 0) {                         /* expanding */
4447             /* push up or down? */
4448             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4449                 if (offset) {
4450                     src = AvARRAY(ary);
4451                     dst = src - diff;
4452                     Move(src, dst, offset, SV*);
4453                 }
4454                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4455                 AvMAX(ary) += diff;
4456                 AvFILLp(ary) += diff;
4457             }
4458             else {
4459                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4460                     av_extend(ary, AvFILLp(ary) + diff);
4461                 AvFILLp(ary) += diff;
4462
4463                 if (after) {
4464                     dst = AvARRAY(ary) + AvFILLp(ary);
4465                     src = dst - diff;
4466                     for (i = after; i; i--) {
4467                         *dst-- = *src--;
4468                     }
4469                 }
4470             }
4471         }
4472
4473         if (newlen) {
4474             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4475         }
4476
4477         MARK = ORIGMARK + 1;
4478         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4479             if (length) {
4480                 Copy(tmparyval, MARK, length, SV*);
4481                 if (AvREAL(ary)) {
4482                     EXTEND_MORTAL(length);
4483                     for (i = length, dst = MARK; i; i--) {
4484                         sv_2mortal(*dst);       /* free them eventualy */
4485                         dst++;
4486                     }
4487                 }
4488             }
4489             MARK += length - 1;
4490         }
4491         else if (length--) {
4492             *MARK = tmparyval[length];
4493             if (AvREAL(ary)) {
4494                 sv_2mortal(*MARK);
4495                 while (length-- > 0)
4496                     SvREFCNT_dec(tmparyval[length]);
4497             }
4498         }
4499         else
4500             *MARK = &PL_sv_undef;
4501         Safefree(tmparyval);
4502     }
4503     SP = MARK;
4504     RETURN;
4505 }
4506
4507 PP(pp_push)
4508 {
4509     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4510     register AV * const ary = (AV*)*++MARK;
4511     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4512
4513     if (mg) {
4514         *MARK-- = SvTIED_obj((SV*)ary, mg);
4515         PUSHMARK(MARK);
4516         PUTBACK;
4517         ENTER;
4518         call_method("PUSH",G_SCALAR|G_DISCARD);
4519         LEAVE;
4520         SPAGAIN;
4521         SP = ORIGMARK;
4522         PUSHi( AvFILL(ary) + 1 );
4523     }
4524     else {
4525         PL_delaymagic = DM_DELAY;
4526         for (++MARK; MARK <= SP; MARK++) {
4527             SV * const sv = newSV(0);
4528             if (*MARK)
4529                 sv_setsv(sv, *MARK);
4530             av_store(ary, AvFILLp(ary)+1, sv);
4531         }
4532         if (PL_delaymagic & DM_ARRAY)
4533             mg_set((SV*)ary);
4534
4535         PL_delaymagic = 0;
4536         SP = ORIGMARK;
4537         PUSHi( AvFILLp(ary) + 1 );
4538     }
4539     RETURN;
4540 }
4541
4542 PP(pp_shift)
4543 {
4544     dVAR;
4545     dSP;
4546     AV * const av = (AV*)POPs;
4547     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4548     EXTEND(SP, 1);
4549     assert (sv);
4550     if (AvREAL(av))
4551         (void)sv_2mortal(sv);
4552     PUSHs(sv);
4553     RETURN;
4554 }
4555
4556 PP(pp_unshift)
4557 {
4558     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4559     register AV *ary = (AV*)*++MARK;
4560     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4561
4562     if (mg) {
4563         *MARK-- = SvTIED_obj((SV*)ary, mg);
4564         PUSHMARK(MARK);
4565         PUTBACK;
4566         ENTER;
4567         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4568         LEAVE;
4569         SPAGAIN;
4570     }
4571     else {
4572         register I32 i = 0;
4573         av_unshift(ary, SP - MARK);
4574         while (MARK < SP) {
4575             SV * const sv = newSVsv(*++MARK);
4576             (void)av_store(ary, i++, sv);
4577         }
4578     }
4579     SP = ORIGMARK;
4580     PUSHi( AvFILL(ary) + 1 );
4581     RETURN;
4582 }
4583
4584 PP(pp_reverse)
4585 {
4586     dVAR; dSP; dMARK;
4587     SV ** const oldsp = SP;
4588
4589     if (GIMME == G_ARRAY) {
4590         MARK++;
4591         while (MARK < SP) {
4592             register SV * const tmp = *MARK;
4593             *MARK++ = *SP;
4594             *SP-- = tmp;
4595         }
4596         /* safe as long as stack cannot get extended in the above */
4597         SP = oldsp;
4598     }
4599     else {
4600         register char *up;
4601         register char *down;
4602         register I32 tmp;
4603         dTARGET;
4604         STRLEN len;
4605         PADOFFSET padoff_du;
4606
4607         SvUTF8_off(TARG);                               /* decontaminate */
4608         if (SP - MARK > 1)
4609             do_join(TARG, &PL_sv_no, MARK, SP);
4610         else
4611             sv_setsv(TARG, (SP > MARK)
4612                     ? *SP
4613                     : (padoff_du = find_rundefsvoffset(),
4614                         (padoff_du == NOT_IN_PAD
4615                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4616                         ? DEFSV : PAD_SVl(padoff_du)));
4617         up = SvPV_force(TARG, len);
4618         if (len > 1) {
4619             if (DO_UTF8(TARG)) {        /* first reverse each character */
4620                 U8* s = (U8*)SvPVX(TARG);
4621                 const U8* send = (U8*)(s + len);
4622                 while (s < send) {
4623                     if (UTF8_IS_INVARIANT(*s)) {
4624                         s++;
4625                         continue;
4626                     }
4627                     else {
4628                         if (!utf8_to_uvchr(s, 0))
4629                             break;
4630                         up = (char*)s;
4631                         s += UTF8SKIP(s);
4632                         down = (char*)(s - 1);
4633                         /* reverse this character */
4634                         while (down > up) {
4635                             tmp = *up;
4636                             *up++ = *down;
4637                             *down-- = (char)tmp;
4638                         }
4639                     }
4640                 }
4641                 up = SvPVX(TARG);
4642             }
4643             down = SvPVX(TARG) + len - 1;
4644             while (down > up) {
4645                 tmp = *up;
4646                 *up++ = *down;
4647                 *down-- = (char)tmp;
4648             }
4649             (void)SvPOK_only_UTF8(TARG);
4650         }
4651         SP = MARK + 1;
4652         SETTARG;
4653     }
4654     RETURN;
4655 }
4656
4657 PP(pp_split)
4658 {
4659     dVAR; dSP; dTARG;
4660     AV *ary;
4661     register IV limit = POPi;                   /* note, negative is forever */
4662     SV * const sv = POPs;
4663     STRLEN len;
4664     register const char *s = SvPV_const(sv, len);
4665     const bool do_utf8 = DO_UTF8(sv);
4666     const char *strend = s + len;
4667     register PMOP *pm;
4668     register REGEXP *rx;
4669     register SV *dstr;
4670     register const char *m;
4671     I32 iters = 0;
4672     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4673     I32 maxiters = slen + 10;
4674     const char *orig;
4675     const I32 origlimit = limit;
4676     I32 realarray = 0;
4677     I32 base;
4678     const I32 gimme = GIMME_V;
4679     const I32 oldsave = PL_savestack_ix;
4680     U32 make_mortal = SVs_TEMP;
4681     bool multiline = 0;
4682     MAGIC *mg = NULL;
4683
4684 #ifdef DEBUGGING
4685     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4686 #else
4687     pm = (PMOP*)POPs;
4688 #endif
4689     if (!pm || !s)
4690         DIE(aTHX_ "panic: pp_split");
4691     rx = PM_GETRE(pm);
4692
4693     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4694              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4695
4696     RX_MATCH_UTF8_set(rx, do_utf8);
4697
4698 #ifdef USE_ITHREADS
4699     if (pm->op_pmreplrootu.op_pmtargetoff) {
4700         ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4701     }
4702 #else
4703     if (pm->op_pmreplrootu.op_pmtargetgv) {
4704         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4705     }
4706 #endif
4707     else if (gimme != G_ARRAY)
4708         ary = GvAVn(PL_defgv);
4709     else
4710         ary = NULL;
4711     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4712         realarray = 1;
4713         PUTBACK;
4714         av_extend(ary,0);
4715         av_clear(ary);
4716         SPAGAIN;
4717         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4718             PUSHMARK(SP);
4719             XPUSHs(SvTIED_obj((SV*)ary, mg));
4720         }
4721         else {
4722             if (!AvREAL(ary)) {
4723                 I32 i;
4724                 AvREAL_on(ary);
4725                 AvREIFY_off(ary);
4726                 for (i = AvFILLp(ary); i >= 0; i--)
4727                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4728             }
4729             /* temporarily switch stacks */
4730             SAVESWITCHSTACK(PL_curstack, ary);
4731             make_mortal = 0;
4732         }
4733     }
4734     base = SP - PL_stack_base;
4735     orig = s;
4736     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4737         if (do_utf8) {
4738             while (*s == ' ' || is_utf8_space((U8*)s))
4739                 s += UTF8SKIP(s);
4740         }
4741         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4742             while (isSPACE_LC(*s))
4743                 s++;
4744         }
4745         else {
4746             while (isSPACE(*s))
4747                 s++;
4748         }
4749     }
4750     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4751         multiline = 1;
4752     }
4753
4754     if (!limit)
4755         limit = maxiters + 2;
4756     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4757         while (--limit) {
4758             m = s;
4759             /* this one uses 'm' and is a negative test */
4760             if (do_utf8) {
4761                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4762                     const int t = UTF8SKIP(m);
4763                     /* is_utf8_space returns FALSE for malform utf8 */
4764                     if (strend - m < t)
4765                         m = strend;
4766                     else
4767                         m += t;
4768                 }
4769             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4770                 while (m < strend && !isSPACE_LC(*m))
4771                     ++m;
4772             } else {
4773                 while (m < strend && !isSPACE(*m))
4774                     ++m;
4775             }
4776             if (m >= strend)
4777                 break;
4778
4779             dstr = newSVpvn_flags(s, m-s,
4780                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4781             XPUSHs(dstr);
4782
4783             /* skip the whitespace found last */
4784             if (do_utf8)
4785                 s = m + UTF8SKIP(m);
4786             else
4787                 s = m + 1;
4788
4789             /* this one uses 's' and is a positive test */
4790             if (do_utf8) {
4791                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4792                     s +=  UTF8SKIP(s);
4793             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4794                 while (s < strend && isSPACE_LC(*s))
4795                     ++s;
4796             } else {
4797                 while (s < strend && isSPACE(*s))
4798                     ++s;
4799             }
4800         }
4801     }
4802     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4803         while (--limit) {
4804             for (m = s; m < strend && *m != '\n'; m++)
4805                 ;
4806             m++;
4807             if (m >= strend)
4808                 break;
4809             dstr = newSVpvn_flags(s, m-s,
4810                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4811             XPUSHs(dstr);
4812             s = m;
4813         }
4814     }
4815     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4816         /*
4817           Pre-extend the stack, either the number of bytes or
4818           characters in the string or a limited amount, triggered by:
4819
4820           my ($x, $y) = split //, $str;
4821             or
4822           split //, $str, $i;
4823         */
4824         const U32 items = limit - 1;
4825         if (items < slen)
4826             EXTEND(SP, items);
4827         else
4828             EXTEND(SP, slen);
4829
4830         if (do_utf8) {
4831             while (--limit) {
4832                 /* keep track of how many bytes we skip over */
4833                 m = s;
4834                 s += UTF8SKIP(s);
4835                 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4836
4837                 PUSHs(dstr);
4838
4839                 if (s >= strend)
4840                     break;
4841             }
4842         } else {
4843             while (--limit) {
4844                 dstr = newSVpvn(s, 1);
4845
4846                 s++;
4847
4848                 if (make_mortal)
4849                     sv_2mortal(dstr);
4850
4851                 PUSHs(dstr);
4852
4853                 if (s >= strend)
4854                     break;
4855             }
4856         }
4857     }
4858     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4859              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4860              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4861              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4862         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4863         SV * const csv = CALLREG_INTUIT_STRING(rx);
4864
4865         len = RX_MINLENRET(rx);
4866         if (len == 1 && !RX_UTF8(rx) && !tail) {
4867             const char c = *SvPV_nolen_const(csv);
4868             while (--limit) {
4869                 for (m = s; m < strend && *m != c; m++)
4870                     ;
4871                 if (m >= strend)
4872                     break;
4873                 dstr = newSVpvn_flags(s, m-s,
4874                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4875                 XPUSHs(dstr);
4876                 /* The rx->minlen is in characters but we want to step
4877                  * s ahead by bytes. */
4878                 if (do_utf8)
4879                     s = (char*)utf8_hop((U8*)m, len);
4880                 else
4881                     s = m + len; /* Fake \n at the end */
4882             }
4883         }
4884         else {
4885             while (s < strend && --limit &&
4886               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4887                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4888             {
4889                 dstr = newSVpvn_flags(s, m-s,
4890                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4891                 XPUSHs(dstr);
4892                 /* The rx->minlen is in characters but we want to step
4893                  * s ahead by bytes. */
4894                 if (do_utf8)
4895                     s = (char*)utf8_hop((U8*)m, len);
4896                 else
4897                     s = m + len; /* Fake \n at the end */
4898             }
4899         }
4900     }
4901     else {
4902         maxiters += slen * RX_NPARENS(rx);
4903         while (s < strend && --limit)
4904         {
4905             I32 rex_return;
4906             PUTBACK;
4907             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4908                             sv, NULL, 0);
4909             SPAGAIN;
4910             if (rex_return == 0)
4911                 break;
4912             TAINT_IF(RX_MATCH_TAINTED(rx));
4913             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4914                 m = s;
4915                 s = orig;
4916                 orig = RX_SUBBEG(rx);
4917                 s = orig + (m - s);
4918                 strend = s + (strend - m);
4919             }
4920             m = RX_OFFS(rx)[0].start + orig;
4921             dstr = newSVpvn_flags(s, m-s,
4922                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4923             XPUSHs(dstr);
4924             if (RX_NPARENS(rx)) {
4925                 I32 i;
4926                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4927                     s = RX_OFFS(rx)[i].start + orig;
4928                     m = RX_OFFS(rx)[i].end + orig;
4929
4930                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4931                        parens that didn't match -- they should be set to
4932                        undef, not the empty string */
4933                     if (m >= orig && s >= orig) {
4934                         dstr = newSVpvn_flags(s, m-s,
4935                                              (do_utf8 ? SVf_UTF8 : 0)
4936                                               | make_mortal);
4937                     }
4938                     else
4939                         dstr = &PL_sv_undef;  /* undef, not "" */
4940                     XPUSHs(dstr);
4941                 }
4942             }
4943             s = RX_OFFS(rx)[0].end + orig;
4944         }
4945     }
4946
4947     iters = (SP - PL_stack_base) - base;
4948     if (iters > maxiters)
4949         DIE(aTHX_ "Split loop");
4950
4951     /* keep field after final delim? */
4952     if (s < strend || (iters && origlimit)) {
4953         const STRLEN l = strend - s;
4954         dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4955         XPUSHs(dstr);
4956         iters++;
4957     }
4958     else if (!origlimit) {
4959         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4960             if (TOPs && !make_mortal)
4961                 sv_2mortal(TOPs);
4962             iters--;
4963             *SP-- = &PL_sv_undef;
4964         }
4965     }
4966
4967     PUTBACK;
4968     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4969     SPAGAIN;
4970     if (realarray) {
4971         if (!mg) {
4972             if (SvSMAGICAL(ary)) {
4973                 PUTBACK;
4974                 mg_set((SV*)ary);
4975                 SPAGAIN;
4976             }
4977             if (gimme == G_ARRAY) {
4978                 EXTEND(SP, iters);
4979                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4980                 SP += iters;
4981                 RETURN;
4982             }
4983         }
4984         else {
4985             PUTBACK;
4986             ENTER;
4987             call_method("PUSH",G_SCALAR|G_DISCARD);
4988             LEAVE;
4989             SPAGAIN;
4990             if (gimme == G_ARRAY) {
4991                 I32 i;
4992                 /* EXTEND should not be needed - we just popped them */
4993                 EXTEND(SP, iters);
4994                 for (i=0; i < iters; i++) {
4995                     SV **svp = av_fetch(ary, i, FALSE);
4996                     PUSHs((svp) ? *svp : &PL_sv_undef);
4997                 }
4998                 RETURN;
4999             }
5000         }
5001     }
5002     else {
5003         if (gimme == G_ARRAY)
5004             RETURN;
5005     }
5006
5007     GETTARGET;
5008     PUSHi(iters);
5009     RETURN;
5010 }
5011
5012 PP(pp_once)
5013 {
5014     dSP;
5015     SV *const sv = PAD_SVl(PL_op->op_targ);
5016
5017     if (SvPADSTALE(sv)) {
5018         /* First time. */
5019         SvPADSTALE_off(sv);
5020         RETURNOP(cLOGOP->op_other);
5021     }
5022     RETURNOP(cLOGOP->op_next);
5023 }
5024
5025 PP(pp_lock)
5026 {
5027     dVAR;
5028     dSP;
5029     dTOPss;
5030     SV *retsv = sv;
5031     SvLOCK(sv);
5032     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5033         || SvTYPE(retsv) == SVt_PVCV) {
5034         retsv = refto(retsv);
5035     }
5036     SETs(retsv);
5037     RETURN;
5038 }
5039
5040
5041 PP(unimplemented_op)
5042 {
5043     dVAR;
5044     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5045         PL_op->op_type);
5046 }
5047
5048 /*
5049  * Local variables:
5050  * c-indentation-style: bsd
5051  * c-basic-offset: 4
5052  * indent-tabs-mode: t
5053  * End:
5054  *
5055  * ex: set ts=8 sts=4 sw=4 noet:
5056  */