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