pp.c

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