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