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 (!isGV_with_GP(sv))
 147             DIE(aTHX_ "Not a GLOB reference");
 148     }
 149     else {
 150         if (!isGV_with_GP(sv)) {
 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 (!isGV_with_GP(gv)) {
 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             break;
 828         }
 829         else if (isGV_with_GP(sv)) {
 830             GP *gp;
 831             HV *stash;
 832
 833             /* undef *Foo:: */
 834             if((stash = GvHV((GV*)sv)) && HvNAME_get(stash))
 835                 mro_isa_changed_in(stash);
 836             /* undef *Pkg::meth_name ... */
 837             else if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
 838                 mro_method_changed_in(stash);
 839
 840             gp_free((GV*)sv);
 841             Newxz(gp, 1, GP);
 842             GvGP(sv) = gp_ref(gp);
 843             GvSV(sv) = newSV(0);
 844             GvLINE(sv) = CopLINE(PL_curcop);
 845             GvEGV(sv) = (GV*)sv;
 846             GvMULTI_on(sv);
 847             break;
 848         }
 849         /* FALL THROUGH */
 850     default:
 851         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 852             SvPV_free(sv);
 853             SvPV_set(sv, NULL);
 854             SvLEN_set(sv, 0);
 855         }
 856         SvOK_off(sv);
 857         SvSETMAGIC(sv);
 858     }
 859
 860     RETPUSHUNDEF;
 861 }
 862
 863 PP(pp_predec)
 864 {
 865     dVAR; dSP;
 866     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 867         DIE(aTHX_ PL_no_modify);
 868     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 869         && SvIVX(TOPs) != IV_MIN)
 870     {
 871         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 872         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 873     }
 874     else
 875         sv_dec(TOPs);
 876     SvSETMAGIC(TOPs);
 877     return NORMAL;
 878 }
 879
 880 PP(pp_postinc)
 881 {
 882     dVAR; dSP; dTARGET;
 883     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 884         DIE(aTHX_ PL_no_modify);
 885     sv_setsv(TARG, TOPs);
 886     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 887         && SvIVX(TOPs) != IV_MAX)
 888     {
 889         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 890         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 891     }
 892     else
 893         sv_inc(TOPs);
 894     SvSETMAGIC(TOPs);
 895     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
 896     if (!SvOK(TARG))
 897         sv_setiv(TARG, 0);
 898     SETs(TARG);
 899     return NORMAL;
 900 }
 901
 902 PP(pp_postdec)
 903 {
 904     dVAR; dSP; dTARGET;
 905     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 906         DIE(aTHX_ PL_no_modify);
 907     sv_setsv(TARG, TOPs);
 908     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 909         && SvIVX(TOPs) != IV_MIN)
 910     {
 911         SvIV_set(TOPs, SvIVX(TOPs) - 1);
 912         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 913     }
 914     else
 915         sv_dec(TOPs);
 916     SvSETMAGIC(TOPs);
 917     SETs(TARG);
 918     return NORMAL;
 919 }
 920
 921 /* Ordinary operators. */
 922
 923 PP(pp_pow)
 924 {
 925     dVAR; dSP; dATARGET; SV *svl, *svr;
 926 #ifdef PERL_PRESERVE_IVUV
 927     bool is_int = 0;
 928 #endif
 929     tryAMAGICbin(pow,opASSIGN);
 930     svl = sv_2num(TOPm1s);
 931     svr = sv_2num(TOPs);
 932 #ifdef PERL_PRESERVE_IVUV
 933     /* For integer to integer power, we do the calculation by hand wherever
 934        we're sure it is safe; otherwise we call pow() and try to convert to
 935        integer afterwards. */
 936     {
 937         SvIV_please(svr);
 938         if (SvIOK(svr)) {
 939             SvIV_please(svl);
 940             if (SvIOK(svl)) {
 941                 UV power;
 942                 bool baseuok;
 943                 UV baseuv;
 944
 945                 if (SvUOK(svr)) {
 946                     power = SvUVX(svr);
 947                 } else {
 948                     const IV iv = SvIVX(svr);
 949                     if (iv >= 0) {
 950                         power = iv;
 951                     } else {
 952                         goto float_it; /* Can't do negative powers this way.  */
 953                     }
 954                 }
 955
 956                 baseuok = SvUOK(svl);
 957                 if (baseuok) {
 958                     baseuv = SvUVX(svl);
 959                 } else {
 960                     const IV iv = SvIVX(svl);
 961                     if (iv >= 0) {
 962                         baseuv = iv;
 963                         baseuok = TRUE; /* effectively it's a UV now */
 964                     } else {
 965                         baseuv = -iv; /* abs, baseuok == false records sign */
 966                     }
 967                 }
 968                 /* now we have integer ** positive integer. */
 969                 is_int = 1;
 970
 971                 /* foo & (foo - 1) is zero only for a power of 2.  */
 972                 if (!(baseuv & (baseuv - 1))) {
 973                     /* We are raising power-of-2 to a positive integer.
 974                        The logic here will work for any base (even non-integer
 975                        bases) but it can be less accurate than
 976                        pow (base,power) or exp (power * log (base)) when the
 977                        intermediate values start to spill out of the mantissa.
 978                        With powers of 2 we know this can't happen.
 979                        And powers of 2 are the favourite thing for perl
 980                        programmers to notice ** not doing what they mean. */
 981                     NV result = 1.0;
 982                     NV base = baseuok ? baseuv : -(NV)baseuv;
 983
 984                     if (power & 1) {
 985                         result *= base;
 986                     }
 987                     while (power >>= 1) {
 988                         base *= base;
 989                         if (power & 1) {
 990                             result *= base;
 991                         }
 992                     }
 993                     SP--;
 994                     SETn( result );
 995                     SvIV_please(svr);
 996                     RETURN;
 997                 } else {
 998                     register unsigned int highbit = 8 * sizeof(UV);
 999                     register unsigned int diff = 8 * sizeof(UV);
1000                     while (diff >>= 1) {
1001                         highbit -= diff;
1002                         if (baseuv >> highbit) {
1003                             highbit += diff;
1004                         }
1005                     }
1006                     /* we now have baseuv < 2 ** highbit */
1007                     if (power * highbit <= 8 * sizeof(UV)) {
1008                         /* result will definitely fit in UV, so use UV math
1009                            on same algorithm as above */
1010                         register UV result = 1;
1011                         register UV base = baseuv;
1012                         const bool odd_power = (bool)(power & 1);
1013                         if (odd_power) {
1014                             result *= base;
1015                         }
1016                         while (power >>= 1) {
1017                             base *= base;
1018                             if (power & 1) {
1019                                 result *= base;
1020                             }
1021                         }
1022                         SP--;
1023                         if (baseuok || !odd_power)
1024                             /* answer is positive */
1025                             SETu( result );
1026                         else if (result <= (UV)IV_MAX)
1027                             /* answer negative, fits in IV */
1028                             SETi( -(IV)result );
1029                         else if (result == (UV)IV_MIN)
1030                             /* 2's complement assumption: special case IV_MIN */
1031                             SETi( IV_MIN );
1032                         else
1033                             /* answer negative, doesn't fit */
1034                             SETn( -(NV)result );
1035                         RETURN;
1036                     }
1037                 }
1038             }
1039         }
1040     }
1041   float_it:
1042 #endif
1043     {
1044         NV right = SvNV(svr);
1045         NV left  = SvNV(svl);
1046         (void)POPs;
1047
1048 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1049     /*
1050     We are building perl with long double support and are on an AIX OS
1051     afflicted with a powl() function that wrongly returns NaNQ for any
1052     negative base.  This was reported to IBM as PMR #23047-379 on
1053     03/06/2006.  The problem exists in at least the following versions
1054     of AIX and the libm fileset, and no doubt others as well:
1055
1056         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1057         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1058         AIX 5.2.0           bos.adt.libm 5.2.0.85
1059
1060     So, until IBM fixes powl(), we provide the following workaround to
1061     handle the problem ourselves.  Our logic is as follows: for
1062     negative bases (left), we use fmod(right, 2) to check if the
1063     exponent is an odd or even integer:
1064
1065         - if odd,  powl(left, right) == -powl(-left, right)
1066         - if even, powl(left, right) ==  powl(-left, right)
1067
1068     If the exponent is not an integer, the result is rightly NaNQ, so
1069     we just return that (as NV_NAN).
1070     */
1071
1072         if (left < 0.0) {
1073             NV mod2 = Perl_fmod( right, 2.0 );
1074             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1075                 SETn( -Perl_pow( -left, right) );
1076             } else if (mod2 == 0.0) {           /* even integer */
1077                 SETn( Perl_pow( -left, right) );
1078             } else {                            /* fractional power */
1079                 SETn( NV_NAN );
1080             }
1081         } else {
1082             SETn( Perl_pow( left, right) );
1083         }
1084 #else
1085         SETn( Perl_pow( left, right) );
1086 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1087
1088 #ifdef PERL_PRESERVE_IVUV
1089         if (is_int)
1090             SvIV_please(svr);
1091 #endif
1092         RETURN;
1093     }
1094 }
1095
1096 PP(pp_multiply)
1097 {
1098     dVAR; dSP; dATARGET; SV *svl, *svr;
1099     tryAMAGICbin(mult,opASSIGN);
1100     svl = sv_2num(TOPm1s);
1101     svr = sv_2num(TOPs);
1102 #ifdef PERL_PRESERVE_IVUV
1103     SvIV_please(svr);
1104     if (SvIOK(svr)) {
1105         /* Unless the left argument is integer in range we are going to have to
1106            use NV maths. Hence only attempt to coerce the right argument if
1107            we know the left is integer.  */
1108         /* Left operand is defined, so is it IV? */
1109         SvIV_please(svl);
1110         if (SvIOK(svl)) {
1111             bool auvok = SvUOK(svl);
1112             bool buvok = SvUOK(svr);
1113             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1114             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1115             UV alow;
1116             UV ahigh;
1117             UV blow;
1118             UV bhigh;
1119
1120             if (auvok) {
1121                 alow = SvUVX(svl);
1122             } else {
1123                 const IV aiv = SvIVX(svl);
1124                 if (aiv >= 0) {
1125                     alow = aiv;
1126                     auvok = TRUE; /* effectively it's a UV now */
1127                 } else {
1128                     alow = -aiv; /* abs, auvok == false records sign */
1129                 }
1130             }
1131             if (buvok) {
1132                 blow = SvUVX(svr);
1133             } else {
1134                 const IV biv = SvIVX(svr);
1135                 if (biv >= 0) {
1136                     blow = biv;
1137                     buvok = TRUE; /* effectively it's a UV now */
1138                 } else {
1139                     blow = -biv; /* abs, buvok == false records sign */
1140                 }
1141             }
1142
1143             /* If this does sign extension on unsigned it's time for plan B  */
1144             ahigh = alow >> (4 * sizeof (UV));
1145             alow &= botmask;
1146             bhigh = blow >> (4 * sizeof (UV));
1147             blow &= botmask;
1148             if (ahigh && bhigh) {
1149                 NOOP;
1150                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1151                    which is overflow. Drop to NVs below.  */
1152             } else if (!ahigh && !bhigh) {
1153                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1154                    so the unsigned multiply cannot overflow.  */
1155                 const UV product = alow * blow;
1156                 if (auvok == buvok) {
1157                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1158                     SP--;
1159                     SETu( product );
1160                     RETURN;
1161                 } else if (product <= (UV)IV_MIN) {
1162                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1163                     /* -ve result, which could overflow an IV  */
1164                     SP--;
1165                     SETi( -(IV)product );
1166                     RETURN;
1167                 } /* else drop to NVs below. */
1168             } else {
1169                 /* One operand is large, 1 small */
1170                 UV product_middle;
1171                 if (bhigh) {
1172                     /* swap the operands */
1173                     ahigh = bhigh;
1174                     bhigh = blow; /* bhigh now the temp var for the swap */
1175                     blow = alow;
1176                     alow = bhigh;
1177                 }
1178                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1179                    multiplies can't overflow. shift can, add can, -ve can.  */
1180                 product_middle = ahigh * blow;
1181                 if (!(product_middle & topmask)) {
1182                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1183                     UV product_low;
1184                     product_middle <<= (4 * sizeof (UV));
1185                     product_low = alow * blow;
1186
1187                     /* as for pp_add, UV + something mustn't get smaller.
1188                        IIRC ANSI mandates this wrapping *behaviour* for
1189                        unsigned whatever the actual representation*/
1190                     product_low += product_middle;
1191                     if (product_low >= product_middle) {
1192                         /* didn't overflow */
1193                         if (auvok == buvok) {
1194                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1195                             SP--;
1196                             SETu( product_low );
1197                             RETURN;
1198                         } else if (product_low <= (UV)IV_MIN) {
1199                             /* 2s complement assumption again  */
1200                             /* -ve result, which could overflow an IV  */
1201                             SP--;
1202                             SETi( -(IV)product_low );
1203                             RETURN;
1204                         } /* else drop to NVs below. */
1205                     }
1206                 } /* product_middle too large */
1207             } /* ahigh && bhigh */
1208         } /* SvIOK(svl) */
1209     } /* SvIOK(svr) */
1210 #endif
1211     {
1212       NV right = SvNV(svr);
1213       NV left  = SvNV(svl);
1214       (void)POPs;
1215       SETn( left * right );
1216       RETURN;
1217     }
1218 }
1219
1220 PP(pp_divide)
1221 {
1222     dVAR; dSP; dATARGET; SV *svl, *svr;
1223     tryAMAGICbin(div,opASSIGN);
1224     svl = sv_2num(TOPm1s);
1225     svr = sv_2num(TOPs);
1226     /* Only try to do UV divide first
1227        if ((SLOPPYDIVIDE is true) or
1228            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1229             to preserve))
1230        The assumption is that it is better to use floating point divide
1231        whenever possible, only doing integer divide first if we can't be sure.
1232        If NV_PRESERVES_UV is true then we know at compile time that no UV
1233        can be too large to preserve, so don't need to compile the code to
1234        test the size of UVs.  */
1235
1236 #ifdef SLOPPYDIVIDE
1237 #  define PERL_TRY_UV_DIVIDE
1238     /* ensure that 20./5. == 4. */
1239 #else
1240 #  ifdef PERL_PRESERVE_IVUV
1241 #    ifndef NV_PRESERVES_UV
1242 #      define PERL_TRY_UV_DIVIDE
1243 #    endif
1244 #  endif
1245 #endif
1246
1247 #ifdef PERL_TRY_UV_DIVIDE
1248     SvIV_please(svr);
1249     if (SvIOK(svr)) {
1250         SvIV_please(svl);
1251         if (SvIOK(svl)) {
1252             bool left_non_neg = SvUOK(svl);
1253             bool right_non_neg = SvUOK(svr);
1254             UV left;
1255             UV right;
1256
1257             if (right_non_neg) {
1258                 right = SvUVX(svr);
1259             }
1260             else {
1261                 const IV biv = SvIVX(svr);
1262                 if (biv >= 0) {
1263                     right = biv;
1264                     right_non_neg = TRUE; /* effectively it's a UV now */
1265                 }
1266                 else {
1267                     right = -biv;
1268                 }
1269             }
1270             /* historically undef()/0 gives a "Use of uninitialized value"
1271                warning before dieing, hence this test goes here.
1272                If it were immediately before the second SvIV_please, then
1273                DIE() would be invoked before left was even inspected, so
1274                no inpsection would give no warning.  */
1275             if (right == 0)
1276                 DIE(aTHX_ "Illegal division by zero");
1277
1278             if (left_non_neg) {
1279                 left = SvUVX(svl);
1280             }
1281             else {
1282                 const IV aiv = SvIVX(svl);
1283                 if (aiv >= 0) {
1284                     left = aiv;
1285                     left_non_neg = TRUE; /* effectively it's a UV now */
1286                 }
1287                 else {
1288                     left = -aiv;
1289                 }
1290             }
1291
1292             if (left >= right
1293 #ifdef SLOPPYDIVIDE
1294                 /* For sloppy divide we always attempt integer division.  */
1295 #else
1296                 /* Otherwise we only attempt it if either or both operands
1297                    would not be preserved by an NV.  If both fit in NVs
1298                    we fall through to the NV divide code below.  However,
1299                    as left >= right to ensure integer result here, we know that
1300                    we can skip the test on the right operand - right big
1301                    enough not to be preserved can't get here unless left is
1302                    also too big.  */
1303
1304                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1305 #endif
1306                 ) {
1307                 /* Integer division can't overflow, but it can be imprecise.  */
1308                 const UV result = left / right;
1309                 if (result * right == left) {
1310                     SP--; /* result is valid */
1311                     if (left_non_neg == right_non_neg) {
1312                         /* signs identical, result is positive.  */
1313                         SETu( result );
1314                         RETURN;
1315                     }
1316                     /* 2s complement assumption */
1317                     if (result <= (UV)IV_MIN)
1318                         SETi( -(IV)result );
1319                     else {
1320                         /* It's exact but too negative for IV. */
1321                         SETn( -(NV)result );
1322                     }
1323                     RETURN;
1324                 } /* tried integer divide but it was not an integer result */
1325             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1326         } /* left wasn't SvIOK */
1327     } /* right wasn't SvIOK */
1328 #endif /* PERL_TRY_UV_DIVIDE */
1329     {
1330         NV right = SvNV(svr);
1331         NV left  = SvNV(svl);
1332         (void)POPs;(void)POPs;
1333 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1334         if (! Perl_isnan(right) && right == 0.0)
1335 #else
1336         if (right == 0.0)
1337 #endif
1338             DIE(aTHX_ "Illegal division by zero");
1339         PUSHn( left / right );
1340         RETURN;
1341     }
1342 }
1343
1344 PP(pp_modulo)
1345 {
1346     dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1347     {
1348         UV left  = 0;
1349         UV right = 0;
1350         bool left_neg = FALSE;
1351         bool right_neg = FALSE;
1352         bool use_double = FALSE;
1353         bool dright_valid = FALSE;
1354         NV dright = 0.0;
1355         NV dleft  = 0.0;
1356         SV * svl;
1357         SV * const svr = sv_2num(TOPs);
1358         SvIV_please(svr);
1359         if (SvIOK(svr)) {
1360             right_neg = !SvUOK(svr);
1361             if (!right_neg) {
1362                 right = SvUVX(svr);
1363             } else {
1364                 const IV biv = SvIVX(svr);
1365                 if (biv >= 0) {
1366                     right = biv;
1367                     right_neg = FALSE; /* effectively it's a UV now */
1368                 } else {
1369                     right = -biv;
1370                 }
1371             }
1372         }
1373         else {
1374             dright = SvNV(svr);
1375             right_neg = dright < 0;
1376             if (right_neg)
1377                 dright = -dright;
1378             if (dright < UV_MAX_P1) {
1379                 right = U_V(dright);
1380                 dright_valid = TRUE; /* In case we need to use double below.  */
1381             } else {
1382                 use_double = TRUE;
1383             }
1384         }
1385         sp--;
1386
1387         /* At this point use_double is only true if right is out of range for
1388            a UV.  In range NV has been rounded down to nearest UV and
1389            use_double false.  */
1390         svl = sv_2num(TOPs);
1391         SvIV_please(svl);
1392         if (!use_double && SvIOK(svl)) {
1393             if (SvIOK(svl)) {
1394                 left_neg = !SvUOK(svl);
1395                 if (!left_neg) {
1396                     left = SvUVX(svl);
1397                 } else {
1398                     const IV aiv = SvIVX(svl);
1399                     if (aiv >= 0) {
1400                         left = aiv;
1401                         left_neg = FALSE; /* effectively it's a UV now */
1402                     } else {
1403                         left = -aiv;
1404                     }
1405                 }
1406             }
1407         }
1408         else {
1409             dleft = SvNV(svl);
1410             left_neg = dleft < 0;
1411             if (left_neg)
1412                 dleft = -dleft;
1413
1414             /* This should be exactly the 5.6 behaviour - if left and right are
1415                both in range for UV then use U_V() rather than floor.  */
1416             if (!use_double) {
1417                 if (dleft < UV_MAX_P1) {
1418                     /* right was in range, so is dleft, so use UVs not double.
1419                      */
1420                     left = U_V(dleft);
1421                 }
1422                 /* left is out of range for UV, right was in range, so promote
1423                    right (back) to double.  */
1424                 else {
1425                     /* The +0.5 is used in 5.6 even though it is not strictly
1426                        consistent with the implicit +0 floor in the U_V()
1427                        inside the #if 1. */
1428                     dleft = Perl_floor(dleft + 0.5);
1429                     use_double = TRUE;
1430                     if (dright_valid)
1431                         dright = Perl_floor(dright + 0.5);
1432                     else
1433                         dright = right;
1434                 }
1435             }
1436         }
1437         sp--;
1438         if (use_double) {
1439             NV dans;
1440
1441             if (!dright)
1442                 DIE(aTHX_ "Illegal modulus zero");
1443
1444             dans = Perl_fmod(dleft, dright);
1445             if ((left_neg != right_neg) && dans)
1446                 dans = dright - dans;
1447             if (right_neg)
1448                 dans = -dans;
1449             sv_setnv(TARG, dans);
1450         }
1451         else {
1452             UV ans;
1453
1454             if (!right)
1455                 DIE(aTHX_ "Illegal modulus zero");
1456
1457             ans = left % right;
1458             if ((left_neg != right_neg) && ans)
1459                 ans = right - ans;
1460             if (right_neg) {
1461                 /* XXX may warn: unary minus operator applied to unsigned type */
1462                 /* could change -foo to be (~foo)+1 instead     */
1463                 if (ans <= ~((UV)IV_MAX)+1)
1464                     sv_setiv(TARG, ~ans+1);
1465                 else
1466                     sv_setnv(TARG, -(NV)ans);
1467             }
1468             else
1469                 sv_setuv(TARG, ans);
1470         }
1471         PUSHTARG;
1472         RETURN;
1473     }
1474 }
1475
1476 PP(pp_repeat)
1477 {
1478   dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1479   {
1480     register IV count;
1481     dPOPss;
1482     SvGETMAGIC(sv);
1483     if (SvIOKp(sv)) {
1484          if (SvUOK(sv)) {
1485               const UV uv = SvUV(sv);
1486               if (uv > IV_MAX)
1487                    count = IV_MAX; /* The best we can do? */
1488               else
1489                    count = uv;
1490          } else {
1491               const IV iv = SvIV(sv);
1492               if (iv < 0)
1493                    count = 0;
1494               else
1495                    count = iv;
1496          }
1497     }
1498     else if (SvNOKp(sv)) {
1499          const NV nv = SvNV(sv);
1500          if (nv < 0.0)
1501               count = 0;
1502          else
1503               count = (IV)nv;
1504     }
1505     else
1506          count = SvIV(sv);
1507     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1508         dMARK;
1509         static const char oom_list_extend[] = "Out of memory during list extend";
1510         const I32 items = SP - MARK;
1511         const I32 max = items * count;
1512
1513         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1514         /* Did the max computation overflow? */
1515         if (items > 0 && max > 0 && (max < items || max < count))
1516            Perl_croak(aTHX_ oom_list_extend);
1517         MEXTEND(MARK, max);
1518         if (count > 1) {
1519             while (SP > MARK) {
1520 #if 0
1521               /* This code was intended to fix 20010809.028:
1522
1523                  $x = 'abcd';
1524                  for (($x =~ /./g) x 2) {
1525                      print chop; # "abcdabcd" expected as output.
1526                  }
1527
1528                * but that change (#11635) broke this code:
1529
1530                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1531
1532                * I can't think of a better fix that doesn't introduce
1533                * an efficiency hit by copying the SVs. The stack isn't
1534                * refcounted, and mortalisation obviously doesn't
1535                * Do The Right Thing when the stack has more than
1536                * one pointer to the same mortal value.
1537                * .robin.
1538                */
1539                 if (*SP) {
1540                     *SP = sv_2mortal(newSVsv(*SP));
1541                     SvREADONLY_on(*SP);
1542                 }
1543 #else
1544                if (*SP)
1545                    SvTEMP_off((*SP));
1546 #endif
1547                 SP--;
1548             }
1549             MARK++;
1550             repeatcpy((char*)(MARK + items), (char*)MARK,
1551                 items * sizeof(SV*), count - 1);
1552             SP += max;
1553         }
1554         else if (count <= 0)
1555             SP -= items;
1556     }
1557     else {      /* Note: mark already snarfed by pp_list */
1558         SV * const tmpstr = POPs;
1559         STRLEN len;
1560         bool isutf;
1561         static const char oom_string_extend[] =
1562           "Out of memory during string extend";
1563
1564         SvSetSV(TARG, tmpstr);
1565         SvPV_force(TARG, len);
1566         isutf = DO_UTF8(TARG);
1567         if (count != 1) {
1568             if (count < 1)
1569                 SvCUR_set(TARG, 0);
1570             else {
1571                 const STRLEN max = (UV)count * len;
1572                 if (len > MEM_SIZE_MAX / count)
1573                      Perl_croak(aTHX_ oom_string_extend);
1574                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1575                 SvGROW(TARG, max + 1);
1576                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1577                 SvCUR_set(TARG, SvCUR(TARG) * count);
1578             }
1579             *SvEND(TARG) = '\0';
1580         }
1581         if (isutf)
1582             (void)SvPOK_only_UTF8(TARG);
1583         else
1584             (void)SvPOK_only(TARG);
1585
1586         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1587             /* The parser saw this as a list repeat, and there
1588                are probably several items on the stack. But we're
1589                in scalar context, and there's no pp_list to save us
1590                now. So drop the rest of the items -- robin@kitsite.com
1591              */
1592             dMARK;
1593             SP = MARK;
1594         }
1595         PUSHTARG;
1596     }
1597     RETURN;
1598   }
1599 }
1600
1601 PP(pp_subtract)
1602 {
1603     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1604     tryAMAGICbin(subtr,opASSIGN);
1605     svl = sv_2num(TOPm1s);
1606     svr = sv_2num(TOPs);
1607     useleft = USE_LEFT(svl);
1608 #ifdef PERL_PRESERVE_IVUV
1609     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1610        "bad things" happen if you rely on signed integers wrapping.  */
1611     SvIV_please(svr);
1612     if (SvIOK(svr)) {
1613         /* Unless the left argument is integer in range we are going to have to
1614            use NV maths. Hence only attempt to coerce the right argument if
1615            we know the left is integer.  */
1616         register UV auv = 0;
1617         bool auvok = FALSE;
1618         bool a_valid = 0;
1619
1620         if (!useleft) {
1621             auv = 0;
1622             a_valid = auvok = 1;
1623             /* left operand is undef, treat as zero.  */
1624         } else {
1625             /* Left operand is defined, so is it IV? */
1626             SvIV_please(svl);
1627             if (SvIOK(svl)) {
1628                 if ((auvok = SvUOK(svl)))
1629                     auv = SvUVX(svl);
1630                 else {
1631                     register const IV aiv = SvIVX(svl);
1632                     if (aiv >= 0) {
1633                         auv = aiv;
1634                         auvok = 1;      /* Now acting as a sign flag.  */
1635                     } else { /* 2s complement assumption for IV_MIN */
1636                         auv = (UV)-aiv;
1637                     }
1638                 }
1639                 a_valid = 1;
1640             }
1641         }
1642         if (a_valid) {
1643             bool result_good = 0;
1644             UV result;
1645             register UV buv;
1646             bool buvok = SvUOK(svr);
1647
1648             if (buvok)
1649                 buv = SvUVX(svr);
1650             else {
1651                 register const IV biv = SvIVX(svr);
1652                 if (biv >= 0) {
1653                     buv = biv;
1654                     buvok = 1;
1655                 } else
1656                     buv = (UV)-biv;
1657             }
1658             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1659                else "IV" now, independent of how it came in.
1660                if a, b represents positive, A, B negative, a maps to -A etc
1661                a - b =>  (a - b)
1662                A - b => -(a + b)
1663                a - B =>  (a + b)
1664                A - B => -(a - b)
1665                all UV maths. negate result if A negative.
1666                subtract if signs same, add if signs differ. */
1667
1668             if (auvok ^ buvok) {
1669                 /* Signs differ.  */
1670                 result = auv + buv;
1671                 if (result >= auv)
1672                     result_good = 1;
1673             } else {
1674                 /* Signs same */
1675                 if (auv >= buv) {
1676                     result = auv - buv;
1677                     /* Must get smaller */
1678                     if (result <= auv)
1679                         result_good = 1;
1680                 } else {
1681                     result = buv - auv;
1682                     if (result <= buv) {
1683                         /* result really should be -(auv-buv). as its negation
1684                            of true value, need to swap our result flag  */
1685                         auvok = !auvok;
1686                         result_good = 1;
1687                     }
1688                 }
1689             }
1690             if (result_good) {
1691                 SP--;
1692                 if (auvok)
1693                     SETu( result );
1694                 else {
1695                     /* Negate result */
1696                     if (result <= (UV)IV_MIN)
1697                         SETi( -(IV)result );
1698                     else {
1699                         /* result valid, but out of range for IV.  */
1700                         SETn( -(NV)result );
1701                     }
1702                 }
1703                 RETURN;
1704             } /* Overflow, drop through to NVs.  */
1705         }
1706     }
1707 #endif
1708     {
1709         NV value = SvNV(svr);
1710         (void)POPs;
1711
1712         if (!useleft) {
1713             /* left operand is undef, treat as zero - value */
1714             SETn(-value);
1715             RETURN;
1716         }
1717         SETn( SvNV(svl) - value );
1718         RETURN;
1719     }
1720 }
1721
1722 PP(pp_left_shift)
1723 {
1724     dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1725     {
1726       const IV shift = POPi;
1727       if (PL_op->op_private & HINT_INTEGER) {
1728         const IV i = TOPi;
1729         SETi(i << shift);
1730       }
1731       else {
1732         const UV u = TOPu;
1733         SETu(u << shift);
1734       }
1735       RETURN;
1736     }
1737 }
1738
1739 PP(pp_right_shift)
1740 {
1741     dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1742     {
1743       const IV shift = POPi;
1744       if (PL_op->op_private & HINT_INTEGER) {
1745         const IV i = TOPi;
1746         SETi(i >> shift);
1747       }
1748       else {
1749         const UV u = TOPu;
1750         SETu(u >> shift);
1751       }
1752       RETURN;
1753     }
1754 }
1755
1756 PP(pp_lt)
1757 {
1758     dVAR; dSP; tryAMAGICbinSET(lt,0);
1759 #ifdef PERL_PRESERVE_IVUV
1760     SvIV_please(TOPs);
1761     if (SvIOK(TOPs)) {
1762         SvIV_please(TOPm1s);
1763         if (SvIOK(TOPm1s)) {
1764             bool auvok = SvUOK(TOPm1s);
1765             bool buvok = SvUOK(TOPs);
1766
1767             if (!auvok && !buvok) { /* ## IV < IV ## */
1768                 const IV aiv = SvIVX(TOPm1s);
1769                 const IV biv = SvIVX(TOPs);
1770
1771                 SP--;
1772                 SETs(boolSV(aiv < biv));
1773                 RETURN;
1774             }
1775             if (auvok && buvok) { /* ## UV < UV ## */
1776                 const UV auv = SvUVX(TOPm1s);
1777                 const UV buv = SvUVX(TOPs);
1778
1779                 SP--;
1780                 SETs(boolSV(auv < buv));
1781                 RETURN;
1782             }
1783             if (auvok) { /* ## UV < IV ## */
1784                 UV auv;
1785                 const IV biv = SvIVX(TOPs);
1786                 SP--;
1787                 if (biv < 0) {
1788                     /* As (a) is a UV, it's >=0, so it cannot be < */
1789                     SETs(&PL_sv_no);
1790                     RETURN;
1791                 }
1792                 auv = SvUVX(TOPs);
1793                 SETs(boolSV(auv < (UV)biv));
1794                 RETURN;
1795             }
1796             { /* ## IV < UV ## */
1797                 const IV aiv = SvIVX(TOPm1s);
1798                 UV buv;
1799
1800                 if (aiv < 0) {
1801                     /* As (b) is a UV, it's >=0, so it must be < */
1802                     SP--;
1803                     SETs(&PL_sv_yes);
1804                     RETURN;
1805                 }
1806                 buv = SvUVX(TOPs);
1807                 SP--;
1808                 SETs(boolSV((UV)aiv < buv));
1809                 RETURN;
1810             }
1811         }
1812     }
1813 #endif
1814 #ifndef NV_PRESERVES_UV
1815 #ifdef PERL_PRESERVE_IVUV
1816     else
1817 #endif
1818     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1819         SP--;
1820         SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1821         RETURN;
1822     }
1823 #endif
1824     {
1825 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1826       dPOPTOPnnrl;
1827       if (Perl_isnan(left) || Perl_isnan(right))
1828           RETSETNO;
1829       SETs(boolSV(left < right));
1830 #else
1831       dPOPnv;
1832       SETs(boolSV(TOPn < value));
1833 #endif
1834       RETURN;
1835     }
1836 }
1837
1838 PP(pp_gt)
1839 {
1840     dVAR; dSP; tryAMAGICbinSET(gt,0);
1841 #ifdef PERL_PRESERVE_IVUV
1842     SvIV_please(TOPs);
1843     if (SvIOK(TOPs)) {
1844         SvIV_please(TOPm1s);
1845         if (SvIOK(TOPm1s)) {
1846             bool auvok = SvUOK(TOPm1s);
1847             bool buvok = SvUOK(TOPs);
1848
1849             if (!auvok && !buvok) { /* ## IV > IV ## */
1850                 const IV aiv = SvIVX(TOPm1s);
1851                 const IV biv = SvIVX(TOPs);
1852
1853                 SP--;
1854                 SETs(boolSV(aiv > biv));
1855                 RETURN;
1856             }
1857             if (auvok && buvok) { /* ## UV > UV ## */
1858                 const UV auv = SvUVX(TOPm1s);
1859                 const UV buv = SvUVX(TOPs);
1860
1861                 SP--;
1862                 SETs(boolSV(auv > buv));
1863                 RETURN;
1864             }
1865             if (auvok) { /* ## UV > IV ## */
1866                 UV auv;
1867                 const IV biv = SvIVX(TOPs);
1868
1869                 SP--;
1870                 if (biv < 0) {
1871                     /* As (a) is a UV, it's >=0, so it must be > */
1872                     SETs(&PL_sv_yes);
1873                     RETURN;
1874                 }
1875                 auv = SvUVX(TOPs);
1876                 SETs(boolSV(auv > (UV)biv));
1877                 RETURN;
1878             }
1879             { /* ## IV > UV ## */
1880                 const IV aiv = SvIVX(TOPm1s);
1881                 UV buv;
1882
1883                 if (aiv < 0) {
1884                     /* As (b) is a UV, it's >=0, so it cannot be > */
1885                     SP--;
1886                     SETs(&PL_sv_no);
1887                     RETURN;
1888                 }
1889                 buv = SvUVX(TOPs);
1890                 SP--;
1891                 SETs(boolSV((UV)aiv > buv));
1892                 RETURN;
1893             }
1894         }
1895     }
1896 #endif
1897 #ifndef NV_PRESERVES_UV
1898 #ifdef PERL_PRESERVE_IVUV
1899     else
1900 #endif
1901     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1902         SP--;
1903         SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1904         RETURN;
1905     }
1906 #endif
1907     {
1908 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1909       dPOPTOPnnrl;
1910       if (Perl_isnan(left) || Perl_isnan(right))
1911           RETSETNO;
1912       SETs(boolSV(left > right));
1913 #else
1914       dPOPnv;
1915       SETs(boolSV(TOPn > value));
1916 #endif
1917       RETURN;
1918     }
1919 }
1920
1921 PP(pp_le)
1922 {
1923     dVAR; dSP; tryAMAGICbinSET(le,0);
1924 #ifdef PERL_PRESERVE_IVUV
1925     SvIV_please(TOPs);
1926     if (SvIOK(TOPs)) {
1927         SvIV_please(TOPm1s);
1928         if (SvIOK(TOPm1s)) {
1929             bool auvok = SvUOK(TOPm1s);
1930             bool buvok = SvUOK(TOPs);
1931
1932             if (!auvok && !buvok) { /* ## IV <= IV ## */
1933                 const IV aiv = SvIVX(TOPm1s);
1934                 const IV biv = SvIVX(TOPs);
1935
1936                 SP--;
1937                 SETs(boolSV(aiv <= biv));
1938                 RETURN;
1939             }
1940             if (auvok && buvok) { /* ## UV <= UV ## */
1941                 UV auv = SvUVX(TOPm1s);
1942                 UV buv = SvUVX(TOPs);
1943
1944                 SP--;
1945                 SETs(boolSV(auv <= buv));
1946                 RETURN;
1947             }
1948             if (auvok) { /* ## UV <= IV ## */
1949                 UV auv;
1950                 const IV biv = SvIVX(TOPs);
1951
1952                 SP--;
1953                 if (biv < 0) {
1954                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1955                     SETs(&PL_sv_no);
1956                     RETURN;
1957                 }
1958                 auv = SvUVX(TOPs);
1959                 SETs(boolSV(auv <= (UV)biv));
1960                 RETURN;
1961             }
1962             { /* ## IV <= UV ## */
1963                 const IV aiv = SvIVX(TOPm1s);
1964                 UV buv;
1965
1966                 if (aiv < 0) {
1967                     /* As (b) is a UV, it's >=0, so a must be <= */
1968                     SP--;
1969                     SETs(&PL_sv_yes);
1970                     RETURN;
1971                 }
1972                 buv = SvUVX(TOPs);
1973                 SP--;
1974                 SETs(boolSV((UV)aiv <= buv));
1975                 RETURN;
1976             }
1977         }
1978     }
1979 #endif
1980 #ifndef NV_PRESERVES_UV
1981 #ifdef PERL_PRESERVE_IVUV
1982     else
1983 #endif
1984     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1985         SP--;
1986         SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1987         RETURN;
1988     }
1989 #endif
1990     {
1991 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1992       dPOPTOPnnrl;
1993       if (Perl_isnan(left) || Perl_isnan(right))
1994           RETSETNO;
1995       SETs(boolSV(left <= right));
1996 #else
1997       dPOPnv;
1998       SETs(boolSV(TOPn <= value));
1999 #endif
2000       RETURN;
2001     }
2002 }
2003
2004 PP(pp_ge)
2005 {
2006     dVAR; dSP; tryAMAGICbinSET(ge,0);
2007 #ifdef PERL_PRESERVE_IVUV
2008     SvIV_please(TOPs);
2009     if (SvIOK(TOPs)) {
2010         SvIV_please(TOPm1s);
2011         if (SvIOK(TOPm1s)) {
2012             bool auvok = SvUOK(TOPm1s);
2013             bool buvok = SvUOK(TOPs);
2014
2015             if (!auvok && !buvok) { /* ## IV >= IV ## */
2016                 const IV aiv = SvIVX(TOPm1s);
2017                 const IV biv = SvIVX(TOPs);
2018
2019                 SP--;
2020                 SETs(boolSV(aiv >= biv));
2021                 RETURN;
2022             }
2023             if (auvok && buvok) { /* ## UV >= UV ## */
2024                 const UV auv = SvUVX(TOPm1s);
2025                 const UV buv = SvUVX(TOPs);
2026
2027                 SP--;
2028                 SETs(boolSV(auv >= buv));
2029                 RETURN;
2030             }
2031             if (auvok) { /* ## UV >= IV ## */
2032                 UV auv;
2033                 const IV biv = SvIVX(TOPs);
2034
2035                 SP--;
2036                 if (biv < 0) {
2037                     /* As (a) is a UV, it's >=0, so it must be >= */
2038                     SETs(&PL_sv_yes);
2039                     RETURN;
2040                 }
2041                 auv = SvUVX(TOPs);
2042                 SETs(boolSV(auv >= (UV)biv));
2043                 RETURN;
2044             }
2045             { /* ## IV >= UV ## */
2046                 const IV aiv = SvIVX(TOPm1s);
2047                 UV buv;
2048
2049                 if (aiv < 0) {
2050                     /* As (b) is a UV, it's >=0, so a cannot be >= */
2051                     SP--;
2052                     SETs(&PL_sv_no);
2053                     RETURN;
2054                 }
2055                 buv = SvUVX(TOPs);
2056                 SP--;
2057                 SETs(boolSV((UV)aiv >= buv));
2058                 RETURN;
2059             }
2060         }
2061     }
2062 #endif
2063 #ifndef NV_PRESERVES_UV
2064 #ifdef PERL_PRESERVE_IVUV
2065     else
2066 #endif
2067     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2068         SP--;
2069         SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2070         RETURN;
2071     }
2072 #endif
2073     {
2074 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2075       dPOPTOPnnrl;
2076       if (Perl_isnan(left) || Perl_isnan(right))
2077           RETSETNO;
2078       SETs(boolSV(left >= right));
2079 #else
2080       dPOPnv;
2081       SETs(boolSV(TOPn >= value));
2082 #endif
2083       RETURN;
2084     }
2085 }
2086
2087 PP(pp_ne)
2088 {
2089     dVAR; dSP; tryAMAGICbinSET(ne,0);
2090 #ifndef NV_PRESERVES_UV
2091     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2092         SP--;
2093         SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2094         RETURN;
2095     }
2096 #endif
2097 #ifdef PERL_PRESERVE_IVUV
2098     SvIV_please(TOPs);
2099     if (SvIOK(TOPs)) {
2100         SvIV_please(TOPm1s);
2101         if (SvIOK(TOPm1s)) {
2102             const bool auvok = SvUOK(TOPm1s);
2103             const bool buvok = SvUOK(TOPs);
2104
2105             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2106                 /* Casting IV to UV before comparison isn't going to matter
2107                    on 2s complement. On 1s complement or sign&magnitude
2108                    (if we have any of them) it could make negative zero
2109                    differ from normal zero. As I understand it. (Need to
2110                    check - is negative zero implementation defined behaviour
2111                    anyway?). NWC  */
2112                 const UV buv = SvUVX(POPs);
2113                 const UV auv = SvUVX(TOPs);
2114
2115                 SETs(boolSV(auv != buv));
2116                 RETURN;
2117             }
2118             {                   /* ## Mixed IV,UV ## */
2119                 IV iv;
2120                 UV uv;
2121
2122                 /* != is commutative so swap if needed (save code) */
2123                 if (auvok) {
2124                     /* swap. top of stack (b) is the iv */
2125                     iv = SvIVX(TOPs);
2126                     SP--;
2127                     if (iv < 0) {
2128                         /* As (a) is a UV, it's >0, so it cannot be == */
2129                         SETs(&PL_sv_yes);
2130                         RETURN;
2131                     }
2132                     uv = SvUVX(TOPs);
2133                 } else {
2134                     iv = SvIVX(TOPm1s);
2135                     SP--;
2136                     if (iv < 0) {
2137                         /* As (b) is a UV, it's >0, so it cannot be == */
2138                         SETs(&PL_sv_yes);
2139                         RETURN;
2140                     }
2141                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2142                 }
2143                 SETs(boolSV((UV)iv != uv));
2144                 RETURN;
2145             }
2146         }
2147     }
2148 #endif
2149     {
2150 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2151       dPOPTOPnnrl;
2152       if (Perl_isnan(left) || Perl_isnan(right))
2153           RETSETYES;
2154       SETs(boolSV(left != right));
2155 #else
2156       dPOPnv;
2157       SETs(boolSV(TOPn != value));
2158 #endif
2159       RETURN;
2160     }
2161 }
2162
2163 PP(pp_ncmp)
2164 {
2165     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2166 #ifndef NV_PRESERVES_UV
2167     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2168         const UV right = PTR2UV(SvRV(POPs));
2169         const UV left = PTR2UV(SvRV(TOPs));
2170         SETi((left > right) - (left < right));
2171         RETURN;
2172     }
2173 #endif
2174 #ifdef PERL_PRESERVE_IVUV
2175     /* Fortunately it seems NaN isn't IOK */
2176     SvIV_please(TOPs);
2177     if (SvIOK(TOPs)) {
2178         SvIV_please(TOPm1s);
2179         if (SvIOK(TOPm1s)) {
2180             const bool leftuvok = SvUOK(TOPm1s);
2181             const bool rightuvok = SvUOK(TOPs);
2182             I32 value;
2183             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2184                 const IV leftiv = SvIVX(TOPm1s);
2185                 const IV rightiv = SvIVX(TOPs);
2186
2187                 if (leftiv > rightiv)
2188                     value = 1;
2189                 else if (leftiv < rightiv)
2190                     value = -1;
2191                 else
2192                     value = 0;
2193             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2194                 const UV leftuv = SvUVX(TOPm1s);
2195                 const UV rightuv = SvUVX(TOPs);
2196
2197                 if (leftuv > rightuv)
2198                     value = 1;
2199                 else if (leftuv < rightuv)
2200                     value = -1;
2201                 else
2202                     value = 0;
2203             } else if (leftuvok) { /* ## UV <=> IV ## */
2204                 const IV rightiv = SvIVX(TOPs);
2205                 if (rightiv < 0) {
2206                     /* As (a) is a UV, it's >=0, so it cannot be < */
2207                     value = 1;
2208                 } else {
2209                     const UV leftuv = SvUVX(TOPm1s);
2210                     if (leftuv > (UV)rightiv) {
2211                         value = 1;
2212                     } else if (leftuv < (UV)rightiv) {
2213                         value = -1;
2214                     } else {
2215                         value = 0;
2216                     }
2217                 }
2218             } else { /* ## IV <=> UV ## */
2219                 const IV leftiv = SvIVX(TOPm1s);
2220                 if (leftiv < 0) {
2221                     /* As (b) is a UV, it's >=0, so it must be < */
2222                     value = -1;
2223                 } else {
2224                     const UV rightuv = SvUVX(TOPs);
2225                     if ((UV)leftiv > rightuv) {
2226                         value = 1;
2227                     } else if ((UV)leftiv < rightuv) {
2228                         value = -1;
2229                     } else {
2230                         value = 0;
2231                     }
2232                 }
2233             }
2234             SP--;
2235             SETi(value);
2236             RETURN;
2237         }
2238     }
2239 #endif
2240     {
2241       dPOPTOPnnrl;
2242       I32 value;
2243
2244 #ifdef Perl_isnan
2245       if (Perl_isnan(left) || Perl_isnan(right)) {
2246           SETs(&PL_sv_undef);
2247           RETURN;
2248        }
2249       value = (left > right) - (left < right);
2250 #else
2251       if (left == right)
2252         value = 0;
2253       else if (left < right)
2254         value = -1;
2255       else if (left > right)
2256         value = 1;
2257       else {
2258         SETs(&PL_sv_undef);
2259         RETURN;
2260       }
2261 #endif
2262       SETi(value);
2263       RETURN;
2264     }
2265 }
2266
2267 PP(pp_sle)
2268 {
2269     dVAR; dSP;
2270
2271     int amg_type = sle_amg;
2272     int multiplier = 1;
2273     int rhs = 1;
2274
2275     switch (PL_op->op_type) {
2276     case OP_SLT:
2277         amg_type = slt_amg;
2278         /* cmp < 0 */
2279         rhs = 0;
2280         break;
2281     case OP_SGT:
2282         amg_type = sgt_amg;
2283         /* cmp > 0 */
2284         multiplier = -1;
2285         rhs = 0;
2286         break;
2287     case OP_SGE:
2288         amg_type = sge_amg;
2289         /* cmp >= 0 */
2290         multiplier = -1;
2291         break;
2292     }
2293
2294     tryAMAGICbinSET_var(amg_type,0);
2295     {
2296       dPOPTOPssrl;
2297       const int cmp = (IN_LOCALE_RUNTIME
2298                  ? sv_cmp_locale(left, right)
2299                  : sv_cmp(left, right));
2300       SETs(boolSV(cmp * multiplier < rhs));
2301       RETURN;
2302     }
2303 }
2304
2305 PP(pp_seq)
2306 {
2307     dVAR; dSP; tryAMAGICbinSET(seq,0);
2308     {
2309       dPOPTOPssrl;
2310       SETs(boolSV(sv_eq(left, right)));
2311       RETURN;
2312     }
2313 }
2314
2315 PP(pp_sne)
2316 {
2317     dVAR; dSP; tryAMAGICbinSET(sne,0);
2318     {
2319       dPOPTOPssrl;
2320       SETs(boolSV(!sv_eq(left, right)));
2321       RETURN;
2322     }
2323 }
2324
2325 PP(pp_scmp)
2326 {
2327     dVAR; dSP; dTARGET;  tryAMAGICbin(scmp,0);
2328     {
2329       dPOPTOPssrl;
2330       const int cmp = (IN_LOCALE_RUNTIME
2331                  ? sv_cmp_locale(left, right)
2332                  : sv_cmp(left, right));
2333       SETi( cmp );
2334       RETURN;
2335     }
2336 }
2337
2338 PP(pp_bit_and)
2339 {
2340     dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2341     {
2342       dPOPTOPssrl;
2343       SvGETMAGIC(left);
2344       SvGETMAGIC(right);
2345       if (SvNIOKp(left) || SvNIOKp(right)) {
2346         if (PL_op->op_private & HINT_INTEGER) {
2347           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2348           SETi(i);
2349         }
2350         else {
2351           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2352           SETu(u);
2353         }
2354       }
2355       else {
2356         do_vop(PL_op->op_type, TARG, left, right);
2357         SETTARG;
2358       }
2359       RETURN;
2360     }
2361 }
2362
2363 PP(pp_bit_or)
2364 {
2365     dVAR; dSP; dATARGET;
2366     const int op_type = PL_op->op_type;
2367
2368     tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2369     {
2370       dPOPTOPssrl;
2371       SvGETMAGIC(left);
2372       SvGETMAGIC(right);
2373       if (SvNIOKp(left) || SvNIOKp(right)) {
2374         if (PL_op->op_private & HINT_INTEGER) {
2375           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2376           const IV r = SvIV_nomg(right);
2377           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2378           SETi(result);
2379         }
2380         else {
2381           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2382           const UV r = SvUV_nomg(right);
2383           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2384           SETu(result);
2385         }
2386       }
2387       else {
2388         do_vop(op_type, TARG, left, right);
2389         SETTARG;
2390       }
2391       RETURN;
2392     }
2393 }
2394
2395 PP(pp_negate)
2396 {
2397     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2398     {
2399         SV * const sv = sv_2num(TOPs);
2400         const int flags = SvFLAGS(sv);
2401         SvGETMAGIC(sv);
2402         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2403             /* It's publicly an integer, or privately an integer-not-float */
2404         oops_its_an_int:
2405             if (SvIsUV(sv)) {
2406                 if (SvIVX(sv) == IV_MIN) {
2407                     /* 2s complement assumption. */
2408                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2409                     RETURN;
2410                 }
2411                 else if (SvUVX(sv) <= IV_MAX) {
2412                     SETi(-SvIVX(sv));
2413                     RETURN;
2414                 }
2415             }
2416             else if (SvIVX(sv) != IV_MIN) {
2417                 SETi(-SvIVX(sv));
2418                 RETURN;
2419             }
2420 #ifdef PERL_PRESERVE_IVUV
2421             else {
2422                 SETu((UV)IV_MIN);
2423                 RETURN;
2424             }
2425 #endif
2426         }
2427         if (SvNIOKp(sv))
2428             SETn(-SvNV(sv));
2429         else if (SvPOKp(sv)) {
2430             STRLEN len;
2431             const char * const s = SvPV_const(sv, len);
2432             if (isIDFIRST(*s)) {
2433                 sv_setpvn(TARG, "-", 1);
2434                 sv_catsv(TARG, sv);
2435             }
2436             else if (*s == '+' || *s == '-') {
2437                 sv_setsv(TARG, sv);
2438                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2439             }
2440             else if (DO_UTF8(sv)) {
2441                 SvIV_please(sv);
2442                 if (SvIOK(sv))
2443                     goto oops_its_an_int;
2444                 if (SvNOK(sv))
2445                     sv_setnv(TARG, -SvNV(sv));
2446                 else {
2447                     sv_setpvn(TARG, "-", 1);
2448                     sv_catsv(TARG, sv);
2449                 }
2450             }
2451             else {
2452                 SvIV_please(sv);
2453                 if (SvIOK(sv))
2454                   goto oops_its_an_int;
2455                 sv_setnv(TARG, -SvNV(sv));
2456             }
2457             SETTARG;
2458         }
2459         else
2460             SETn(-SvNV(sv));
2461     }
2462     RETURN;
2463 }
2464
2465 PP(pp_not)
2466 {
2467     dVAR; dSP; tryAMAGICunSET(not);
2468     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2469     return NORMAL;
2470 }
2471
2472 PP(pp_complement)
2473 {
2474     dVAR; dSP; dTARGET; tryAMAGICun(compl);
2475     {
2476       dTOPss;
2477       SvGETMAGIC(sv);
2478       if (SvNIOKp(sv)) {
2479         if (PL_op->op_private & HINT_INTEGER) {
2480           const IV i = ~SvIV_nomg(sv);
2481           SETi(i);
2482         }
2483         else {
2484           const UV u = ~SvUV_nomg(sv);
2485           SETu(u);
2486         }
2487       }
2488       else {
2489         register U8 *tmps;
2490         register I32 anum;
2491         STRLEN len;
2492
2493         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2494         sv_setsv_nomg(TARG, sv);
2495         tmps = (U8*)SvPV_force(TARG, len);
2496         anum = len;
2497         if (SvUTF8(TARG)) {
2498           /* Calculate exact length, let's not estimate. */
2499           STRLEN targlen = 0;
2500           STRLEN l;
2501           UV nchar = 0;
2502           UV nwide = 0;
2503           U8 * const send = tmps + len;
2504           U8 * const origtmps = tmps;
2505           const UV utf8flags = UTF8_ALLOW_ANYUV;
2506
2507           while (tmps < send) {
2508             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2509             tmps += l;
2510             targlen += UNISKIP(~c);
2511             nchar++;
2512             if (c > 0xff)
2513                 nwide++;
2514           }
2515
2516           /* Now rewind strings and write them. */
2517           tmps = origtmps;
2518
2519           if (nwide) {
2520               U8 *result;
2521               U8 *p;
2522
2523               Newx(result, targlen + 1, U8);
2524               p = result;
2525               while (tmps < send) {
2526                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2527                   tmps += l;
2528                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2529               }
2530               *p = '\0';
2531               sv_usepvn_flags(TARG, (char*)result, targlen,
2532                               SV_HAS_TRAILING_NUL);
2533               SvUTF8_on(TARG);
2534           }
2535           else {
2536               U8 *result;
2537               U8 *p;
2538
2539               Newx(result, nchar + 1, U8);
2540               p = result;
2541               while (tmps < send) {
2542                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2543                   tmps += l;
2544                   *p++ = ~c;
2545               }
2546               *p = '\0';
2547               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2548               SvUTF8_off(TARG);
2549           }
2550           SETs(TARG);
2551           RETURN;
2552         }
2553 #ifdef LIBERAL
2554         {
2555             register long *tmpl;
2556             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2557                 *tmps = ~*tmps;
2558             tmpl = (long*)tmps;
2559             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2560                 *tmpl = ~*tmpl;
2561             tmps = (U8*)tmpl;
2562         }
2563 #endif
2564         for ( ; anum > 0; anum--, tmps++)
2565             *tmps = ~*tmps;
2566
2567         SETs(TARG);
2568       }
2569       RETURN;
2570     }
2571 }
2572
2573 /* integer versions of some of the above */
2574
2575 PP(pp_i_multiply)
2576 {
2577     dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2578     {
2579       dPOPTOPiirl;
2580       SETi( left * right );
2581       RETURN;
2582     }
2583 }
2584
2585 PP(pp_i_divide)
2586 {
2587     IV num;
2588     dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2589     {
2590       dPOPiv;
2591       if (value == 0)
2592           DIE(aTHX_ "Illegal division by zero");
2593       num = POPi;
2594
2595       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2596       if (value == -1)
2597           value = - num;
2598       else
2599           value = num / value;
2600       PUSHi( value );
2601       RETURN;
2602     }
2603 }
2604
2605 #if defined(__GLIBC__) && IVSIZE == 8
2606 STATIC
2607 PP(pp_i_modulo_0)
2608 #else
2609 PP(pp_i_modulo)
2610 #endif
2611 {
2612      /* This is the vanilla old i_modulo. */
2613      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2614      {
2615           dPOPTOPiirl;
2616           if (!right)
2617                DIE(aTHX_ "Illegal modulus zero");
2618           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2619           if (right == -1)
2620               SETi( 0 );
2621           else
2622               SETi( left % right );
2623           RETURN;
2624      }
2625 }
2626
2627 #if defined(__GLIBC__) && IVSIZE == 8
2628 STATIC
2629 PP(pp_i_modulo_1)
2630
2631 {
2632      /* This is the i_modulo with the workaround for the _moddi3 bug
2633       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2634       * See below for pp_i_modulo. */
2635      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2636      {
2637           dPOPTOPiirl;
2638           if (!right)
2639                DIE(aTHX_ "Illegal modulus zero");
2640           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2641           if (right == -1)
2642               SETi( 0 );
2643           else
2644               SETi( left % PERL_ABS(right) );
2645           RETURN;
2646      }
2647 }
2648
2649 PP(pp_i_modulo)
2650 {
2651      dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2652      {
2653           dPOPTOPiirl;
2654           if (!right)
2655                DIE(aTHX_ "Illegal modulus zero");
2656           /* The assumption is to use hereafter the old vanilla version... */
2657           PL_op->op_ppaddr =
2658                PL_ppaddr[OP_I_MODULO] =
2659                    Perl_pp_i_modulo_0;
2660           /* .. but if we have glibc, we might have a buggy _moddi3
2661            * (at least glicb 2.2.5 is known to have this bug), in other
2662            * words our integer modulus with negative quad as the second
2663            * argument might be broken.  Test for this and re-patch the
2664            * opcode dispatch table if that is the case, remembering to
2665            * also apply the workaround so that this first round works
2666            * right, too.  See [perl #9402] for more information. */
2667           {
2668                IV l =   3;
2669                IV r = -10;
2670                /* Cannot do this check with inlined IV constants since
2671                 * that seems to work correctly even with the buggy glibc. */
2672                if (l % r == -3) {
2673                     /* Yikes, we have the bug.
2674                      * Patch in the workaround version. */
2675                     PL_op->op_ppaddr =
2676                          PL_ppaddr[OP_I_MODULO] =
2677                              &Perl_pp_i_modulo_1;
2678                     /* Make certain we work right this time, too. */
2679                     right = PERL_ABS(right);
2680                }
2681           }
2682           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2683           if (right == -1)
2684               SETi( 0 );
2685           else
2686               SETi( left % right );
2687           RETURN;
2688      }
2689 }
2690 #endif
2691
2692 PP(pp_i_add)
2693 {
2694     dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2695     {
2696       dPOPTOPiirl_ul;
2697       SETi( left + right );
2698       RETURN;
2699     }
2700 }
2701
2702 PP(pp_i_subtract)
2703 {
2704     dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2705     {
2706       dPOPTOPiirl_ul;
2707       SETi( left - right );
2708       RETURN;
2709     }
2710 }
2711
2712 PP(pp_i_lt)
2713 {
2714     dVAR; dSP; tryAMAGICbinSET(lt,0);
2715     {
2716       dPOPTOPiirl;
2717       SETs(boolSV(left < right));
2718       RETURN;
2719     }
2720 }
2721
2722 PP(pp_i_gt)
2723 {
2724     dVAR; dSP; tryAMAGICbinSET(gt,0);
2725     {
2726       dPOPTOPiirl;
2727       SETs(boolSV(left > right));
2728       RETURN;
2729     }
2730 }
2731
2732 PP(pp_i_le)
2733 {
2734     dVAR; dSP; tryAMAGICbinSET(le,0);
2735     {
2736       dPOPTOPiirl;
2737       SETs(boolSV(left <= right));
2738       RETURN;
2739     }
2740 }
2741
2742 PP(pp_i_ge)
2743 {
2744     dVAR; dSP; tryAMAGICbinSET(ge,0);
2745     {
2746       dPOPTOPiirl;
2747       SETs(boolSV(left >= right));
2748       RETURN;
2749     }
2750 }
2751
2752 PP(pp_i_eq)
2753 {
2754     dVAR; dSP; tryAMAGICbinSET(eq,0);
2755     {
2756       dPOPTOPiirl;
2757       SETs(boolSV(left == right));
2758       RETURN;
2759     }
2760 }
2761
2762 PP(pp_i_ne)
2763 {
2764     dVAR; dSP; tryAMAGICbinSET(ne,0);
2765     {
2766       dPOPTOPiirl;
2767       SETs(boolSV(left != right));
2768       RETURN;
2769     }
2770 }
2771
2772 PP(pp_i_ncmp)
2773 {
2774     dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2775     {
2776       dPOPTOPiirl;
2777       I32 value;
2778
2779       if (left > right)
2780         value = 1;
2781       else if (left < right)
2782         value = -1;
2783       else
2784         value = 0;
2785       SETi(value);
2786       RETURN;
2787     }
2788 }
2789
2790 PP(pp_i_negate)
2791 {
2792     dVAR; dSP; dTARGET; tryAMAGICun(neg);
2793     SETi(-TOPi);
2794     RETURN;
2795 }
2796
2797 /* High falutin' math. */
2798
2799 PP(pp_atan2)
2800 {
2801     dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2802     {
2803       dPOPTOPnnrl;
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
4618             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4619                 report_uninit(TARG);
4620         }
4621
4622         up = SvPV_force(TARG, len);
4623         if (len > 1) {
4624             if (DO_UTF8(TARG)) {        /* first reverse each character */
4625                 U8* s = (U8*)SvPVX(TARG);
4626                 const U8* send = (U8*)(s + len);
4627                 while (s < send) {
4628                     if (UTF8_IS_INVARIANT(*s)) {
4629                         s++;
4630                         continue;
4631                     }
4632                     else {
4633                         if (!utf8_to_uvchr(s, 0))
4634                             break;
4635                         up = (char*)s;
4636                         s += UTF8SKIP(s);
4637                         down = (char*)(s - 1);
4638                         /* reverse this character */
4639                         while (down > up) {
4640                             tmp = *up;
4641                             *up++ = *down;
4642                             *down-- = (char)tmp;
4643                         }
4644                     }
4645                 }
4646                 up = SvPVX(TARG);
4647             }
4648             down = SvPVX(TARG) + len - 1;
4649             while (down > up) {
4650                 tmp = *up;
4651                 *up++ = *down;
4652                 *down-- = (char)tmp;
4653             }
4654             (void)SvPOK_only_UTF8(TARG);
4655         }
4656         SP = MARK + 1;
4657         SETTARG;
4658     }
4659     RETURN;
4660 }
4661
4662 PP(pp_split)
4663 {
4664     dVAR; dSP; dTARG;
4665     AV *ary;
4666     register IV limit = POPi;                   /* note, negative is forever */
4667     SV * const sv = POPs;
4668     STRLEN len;
4669     register const char *s = SvPV_const(sv, len);
4670     const bool do_utf8 = DO_UTF8(sv);
4671     const char *strend = s + len;
4672     register PMOP *pm;
4673     register REGEXP *rx;
4674     register SV *dstr;
4675     register const char *m;
4676     I32 iters = 0;
4677     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4678     I32 maxiters = slen + 10;
4679     const char *orig;
4680     const I32 origlimit = limit;
4681     I32 realarray = 0;
4682     I32 base;
4683     const I32 gimme = GIMME_V;
4684     const I32 oldsave = PL_savestack_ix;
4685     U32 make_mortal = SVs_TEMP;
4686     bool multiline = 0;
4687     MAGIC *mg = NULL;
4688
4689 #ifdef DEBUGGING
4690     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4691 #else
4692     pm = (PMOP*)POPs;
4693 #endif
4694     if (!pm || !s)
4695         DIE(aTHX_ "panic: pp_split");
4696     rx = PM_GETRE(pm);
4697
4698     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4699              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4700
4701     RX_MATCH_UTF8_set(rx, do_utf8);
4702
4703 #ifdef USE_ITHREADS
4704     if (pm->op_pmreplrootu.op_pmtargetoff) {
4705         ary = GvAVn((GV*)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
4706     }
4707 #else
4708     if (pm->op_pmreplrootu.op_pmtargetgv) {
4709         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4710     }
4711 #endif
4712     else if (gimme != G_ARRAY)
4713         ary = GvAVn(PL_defgv);
4714     else
4715         ary = NULL;
4716     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4717         realarray = 1;
4718         PUTBACK;
4719         av_extend(ary,0);
4720         av_clear(ary);
4721         SPAGAIN;
4722         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4723             PUSHMARK(SP);
4724             XPUSHs(SvTIED_obj((SV*)ary, mg));
4725         }
4726         else {
4727             if (!AvREAL(ary)) {
4728                 I32 i;
4729                 AvREAL_on(ary);
4730                 AvREIFY_off(ary);
4731                 for (i = AvFILLp(ary); i >= 0; i--)
4732                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4733             }
4734             /* temporarily switch stacks */
4735             SAVESWITCHSTACK(PL_curstack, ary);
4736             make_mortal = 0;
4737         }
4738     }
4739     base = SP - PL_stack_base;
4740     orig = s;
4741     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
4742         if (do_utf8) {
4743             while (*s == ' ' || is_utf8_space((U8*)s))
4744                 s += UTF8SKIP(s);
4745         }
4746         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4747             while (isSPACE_LC(*s))
4748                 s++;
4749         }
4750         else {
4751             while (isSPACE(*s))
4752                 s++;
4753         }
4754     }
4755     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
4756         multiline = 1;
4757     }
4758
4759     if (!limit)
4760         limit = maxiters + 2;
4761     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
4762         while (--limit) {
4763             m = s;
4764             /* this one uses 'm' and is a negative test */
4765             if (do_utf8) {
4766                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
4767                     const int t = UTF8SKIP(m);
4768                     /* is_utf8_space returns FALSE for malform utf8 */
4769                     if (strend - m < t)
4770                         m = strend;
4771                     else
4772                         m += t;
4773                 }
4774             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4775                 while (m < strend && !isSPACE_LC(*m))
4776                     ++m;
4777             } else {
4778                 while (m < strend && !isSPACE(*m))
4779                     ++m;
4780             }
4781             if (m >= strend)
4782                 break;
4783
4784             dstr = newSVpvn_flags(s, m-s,
4785                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4786             XPUSHs(dstr);
4787
4788             /* skip the whitespace found last */
4789             if (do_utf8)
4790                 s = m + UTF8SKIP(m);
4791             else
4792                 s = m + 1;
4793
4794             /* this one uses 's' and is a positive test */
4795             if (do_utf8) {
4796                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
4797                     s +=  UTF8SKIP(s);
4798             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
4799                 while (s < strend && isSPACE_LC(*s))
4800                     ++s;
4801             } else {
4802                 while (s < strend && isSPACE(*s))
4803                     ++s;
4804             }
4805         }
4806     }
4807     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
4808         while (--limit) {
4809             for (m = s; m < strend && *m != '\n'; m++)
4810                 ;
4811             m++;
4812             if (m >= strend)
4813                 break;
4814             dstr = newSVpvn_flags(s, m-s,
4815                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4816             XPUSHs(dstr);
4817             s = m;
4818         }
4819     }
4820     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
4821         /*
4822           Pre-extend the stack, either the number of bytes or
4823           characters in the string or a limited amount, triggered by:
4824
4825           my ($x, $y) = split //, $str;
4826             or
4827           split //, $str, $i;
4828         */
4829         const U32 items = limit - 1;
4830         if (items < slen)
4831             EXTEND(SP, items);
4832         else
4833             EXTEND(SP, slen);
4834
4835         if (do_utf8) {
4836             while (--limit) {
4837                 /* keep track of how many bytes we skip over */
4838                 m = s;
4839                 s += UTF8SKIP(s);
4840                 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
4841
4842                 PUSHs(dstr);
4843
4844                 if (s >= strend)
4845                     break;
4846             }
4847         } else {
4848             while (--limit) {
4849                 dstr = newSVpvn(s, 1);
4850
4851                 s++;
4852
4853                 if (make_mortal)
4854                     sv_2mortal(dstr);
4855
4856                 PUSHs(dstr);
4857
4858                 if (s >= strend)
4859                     break;
4860             }
4861         }
4862     }
4863     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
4864              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
4865              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
4866              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
4867         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
4868         SV * const csv = CALLREG_INTUIT_STRING(rx);
4869
4870         len = RX_MINLENRET(rx);
4871         if (len == 1 && !RX_UTF8(rx) && !tail) {
4872             const char c = *SvPV_nolen_const(csv);
4873             while (--limit) {
4874                 for (m = s; m < strend && *m != c; m++)
4875                     ;
4876                 if (m >= strend)
4877                     break;
4878                 dstr = newSVpvn_flags(s, m-s,
4879                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4880                 XPUSHs(dstr);
4881                 /* The rx->minlen is in characters but we want to step
4882                  * s ahead by bytes. */
4883                 if (do_utf8)
4884                     s = (char*)utf8_hop((U8*)m, len);
4885                 else
4886                     s = m + len; /* Fake \n at the end */
4887             }
4888         }
4889         else {
4890             while (s < strend && --limit &&
4891               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4892                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4893             {
4894                 dstr = newSVpvn_flags(s, m-s,
4895                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4896                 XPUSHs(dstr);
4897                 /* The rx->minlen is in characters but we want to step
4898                  * s ahead by bytes. */
4899                 if (do_utf8)
4900                     s = (char*)utf8_hop((U8*)m, len);
4901                 else
4902                     s = m + len; /* Fake \n at the end */
4903             }
4904         }
4905     }
4906     else {
4907         maxiters += slen * RX_NPARENS(rx);
4908         while (s < strend && --limit)
4909         {
4910             I32 rex_return;
4911             PUTBACK;
4912             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4913                             sv, NULL, 0);
4914             SPAGAIN;
4915             if (rex_return == 0)
4916                 break;
4917             TAINT_IF(RX_MATCH_TAINTED(rx));
4918             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
4919                 m = s;
4920                 s = orig;
4921                 orig = RX_SUBBEG(rx);
4922                 s = orig + (m - s);
4923                 strend = s + (strend - m);
4924             }
4925             m = RX_OFFS(rx)[0].start + orig;
4926             dstr = newSVpvn_flags(s, m-s,
4927                                   (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4928             XPUSHs(dstr);
4929             if (RX_NPARENS(rx)) {
4930                 I32 i;
4931                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
4932                     s = RX_OFFS(rx)[i].start + orig;
4933                     m = RX_OFFS(rx)[i].end + orig;
4934
4935                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4936                        parens that didn't match -- they should be set to
4937                        undef, not the empty string */
4938                     if (m >= orig && s >= orig) {
4939                         dstr = newSVpvn_flags(s, m-s,
4940                                              (do_utf8 ? SVf_UTF8 : 0)
4941                                               | make_mortal);
4942                     }
4943                     else
4944                         dstr = &PL_sv_undef;  /* undef, not "" */
4945                     XPUSHs(dstr);
4946                 }
4947             }
4948             s = RX_OFFS(rx)[0].end + orig;
4949         }
4950     }
4951
4952     iters = (SP - PL_stack_base) - base;
4953     if (iters > maxiters)
4954         DIE(aTHX_ "Split loop");
4955
4956     /* keep field after final delim? */
4957     if (s < strend || (iters && origlimit)) {
4958         const STRLEN l = strend - s;
4959         dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
4960         XPUSHs(dstr);
4961         iters++;
4962     }
4963     else if (!origlimit) {
4964         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4965             if (TOPs && !make_mortal)
4966                 sv_2mortal(TOPs);
4967             iters--;
4968             *SP-- = &PL_sv_undef;
4969         }
4970     }
4971
4972     PUTBACK;
4973     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4974     SPAGAIN;
4975     if (realarray) {
4976         if (!mg) {
4977             if (SvSMAGICAL(ary)) {
4978                 PUTBACK;
4979                 mg_set((SV*)ary);
4980                 SPAGAIN;
4981             }
4982             if (gimme == G_ARRAY) {
4983                 EXTEND(SP, iters);
4984                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4985                 SP += iters;
4986                 RETURN;
4987             }
4988         }
4989         else {
4990             PUTBACK;
4991             ENTER;
4992             call_method("PUSH",G_SCALAR|G_DISCARD);
4993             LEAVE;
4994             SPAGAIN;
4995             if (gimme == G_ARRAY) {
4996                 I32 i;
4997                 /* EXTEND should not be needed - we just popped them */
4998                 EXTEND(SP, iters);
4999                 for (i=0; i < iters; i++) {
5000                     SV **svp = av_fetch(ary, i, FALSE);
5001                     PUSHs((svp) ? *svp : &PL_sv_undef);
5002                 }
5003                 RETURN;
5004             }
5005         }
5006     }
5007     else {
5008         if (gimme == G_ARRAY)
5009             RETURN;
5010     }
5011
5012     GETTARGET;
5013     PUSHi(iters);
5014     RETURN;
5015 }
5016
5017 PP(pp_once)
5018 {
5019     dSP;
5020     SV *const sv = PAD_SVl(PL_op->op_targ);
5021
5022     if (SvPADSTALE(sv)) {
5023         /* First time. */
5024         SvPADSTALE_off(sv);
5025         RETURNOP(cLOGOP->op_other);
5026     }
5027     RETURNOP(cLOGOP->op_next);
5028 }
5029
5030 PP(pp_lock)
5031 {
5032     dVAR;
5033     dSP;
5034     dTOPss;
5035     SV *retsv = sv;
5036     SvLOCK(sv);
5037     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5038         || SvTYPE(retsv) == SVt_PVCV) {
5039         retsv = refto(retsv);
5040     }
5041     SETs(retsv);
5042     RETURN;
5043 }
5044
5045
5046 PP(unimplemented_op)
5047 {
5048     dVAR;
5049     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5050         PL_op->op_type);
5051 }
5052
5053 /*
5054  * Local variables:
5055  * c-indentation-style: bsd
5056  * c-basic-offset: 4
5057  * indent-tabs-mode: t
5058  * End:
5059  *
5060  * ex: set ts=8 sts=4 sw=4 noet:
5061  */