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