pp.c

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