pp.c

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