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             SvREFCNT_dec(repl_sv_copy);
3204         }
3205         else if (lvalue) {              /* it's an lvalue! */
3206             if (!SvGMAGICAL(sv)) {
3207                 if (SvROK(sv)) {
3208                     SvPV_force_nolen(sv);
3209                     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3210                                    "Attempt to use reference as lvalue in substr");
3211                 }
3212                 if (isGV_with_GP(sv))
3213                     SvPV_force_nolen(sv);
3214                 else if (SvOK(sv))      /* is it defined ? */
3215                     (void)SvPOK_only_UTF8(sv);
3216                 else
3217                     sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3218             }
3219
3220             if (SvTYPE(TARG) < SVt_PVLV) {
3221                 sv_upgrade(TARG, SVt_PVLV);
3222                 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3223             }
3224
3225             LvTYPE(TARG) = 'x';
3226             if (LvTARG(TARG) != sv) {
3227                 SvREFCNT_dec(LvTARG(TARG));
3228                 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3229             }
3230             LvTARGOFF(TARG) = upos;
3231             LvTARGLEN(TARG) = urem;
3232         }
3233     }
3234     SPAGAIN;
3235     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3236     RETURN;
3237 }
3238
3239 PP(pp_vec)
3240 {
3241     dVAR; dSP; dTARGET;
3242     register const IV size   = POPi;
3243     register const IV offset = POPi;
3244     register SV * const src = POPs;
3245     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3246
3247     SvTAINTED_off(TARG);                /* decontaminate */
3248     if (lvalue) {                       /* it's an lvalue! */
3249         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3250             TARG = sv_newmortal();
3251         if (SvTYPE(TARG) < SVt_PVLV) {
3252             sv_upgrade(TARG, SVt_PVLV);
3253             sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3254         }
3255         LvTYPE(TARG) = 'v';
3256         if (LvTARG(TARG) != src) {
3257             SvREFCNT_dec(LvTARG(TARG));
3258             LvTARG(TARG) = SvREFCNT_inc_simple(src);
3259         }
3260         LvTARGOFF(TARG) = offset;
3261         LvTARGLEN(TARG) = size;
3262     }
3263
3264     sv_setuv(TARG, do_vecget(src, offset, size));
3265     PUSHs(TARG);
3266     RETURN;
3267 }
3268
3269 PP(pp_index)
3270 {
3271     dVAR; dSP; dTARGET;
3272     SV *big;
3273     SV *little;
3274     SV *temp = NULL;
3275     STRLEN biglen;
3276     STRLEN llen = 0;
3277     I32 offset;
3278     I32 retval;
3279     const char *big_p;
3280     const char *little_p;
3281     const I32 arybase = CopARYBASE_get(PL_curcop);
3282     bool big_utf8;
3283     bool little_utf8;
3284     const bool is_index = PL_op->op_type == OP_INDEX;
3285
3286     if (MAXARG >= 3) {
3287         /* arybase is in characters, like offset, so combine prior to the
3288            UTF-8 to bytes calculation.  */
3289         offset = POPi - arybase;
3290     }
3291     little = POPs;
3292     big = POPs;
3293     big_p = SvPV_const(big, biglen);
3294     little_p = SvPV_const(little, llen);
3295
3296     big_utf8 = DO_UTF8(big);
3297     little_utf8 = DO_UTF8(little);
3298     if (big_utf8 ^ little_utf8) {
3299         /* One needs to be upgraded.  */
3300         if (little_utf8 && !PL_encoding) {
3301             /* Well, maybe instead we might be able to downgrade the small
3302                string?  */
3303             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3304                                                      &little_utf8);
3305             if (little_utf8) {
3306                 /* If the large string is ISO-8859-1, and it's not possible to
3307                    convert the small string to ISO-8859-1, then there is no
3308                    way that it could be found anywhere by index.  */
3309                 retval = -1;
3310                 goto fail;
3311             }
3312
3313             /* At this point, pv is a malloc()ed string. So donate it to temp
3314                to ensure it will get free()d  */
3315             little = temp = newSV(0);
3316             sv_usepvn(temp, pv, llen);
3317             little_p = SvPVX(little);
3318         } else {
3319             temp = little_utf8
3320                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3321
3322             if (PL_encoding) {
3323                 sv_recode_to_utf8(temp, PL_encoding);
3324             } else {
3325                 sv_utf8_upgrade(temp);
3326             }
3327             if (little_utf8) {
3328                 big = temp;
3329                 big_utf8 = TRUE;
3330                 big_p = SvPV_const(big, biglen);
3331             } else {
3332                 little = temp;
3333                 little_p = SvPV_const(little, llen);
3334             }
3335         }
3336     }
3337     if (SvGAMAGIC(big)) {
3338         /* Life just becomes a lot easier if I use a temporary here.
3339            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3340            will trigger magic and overloading again, as will fbm_instr()
3341         */
3342         big = newSVpvn_flags(big_p, biglen,
3343                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3344         big_p = SvPVX(big);
3345     }
3346     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3347         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3348            warn on undef, and we've already triggered a warning with the
3349            SvPV_const some lines above. We can't remove that, as we need to
3350            call some SvPV to trigger overloading early and find out if the
3351            string is UTF-8.
3352            This is all getting to messy. The API isn't quite clean enough,
3353            because data access has side effects.
3354         */
3355         little = newSVpvn_flags(little_p, llen,
3356                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3357         little_p = SvPVX(little);
3358     }
3359
3360     if (MAXARG < 3)
3361         offset = is_index ? 0 : biglen;
3362     else {
3363         if (big_utf8 && offset > 0)
3364             sv_pos_u2b(big, &offset, 0);
3365         if (!is_index)
3366             offset += llen;
3367     }
3368     if (offset < 0)
3369         offset = 0;
3370     else if (offset > (I32)biglen)
3371         offset = biglen;
3372     if (!(little_p = is_index
3373           ? fbm_instr((unsigned char*)big_p + offset,
3374                       (unsigned char*)big_p + biglen, little, 0)
3375           : rninstr(big_p,  big_p  + offset,
3376                     little_p, little_p + llen)))
3377         retval = -1;
3378     else {
3379         retval = little_p - big_p;
3380         if (retval > 0 && big_utf8)
3381             sv_pos_b2u(big, &retval);
3382     }
3383     SvREFCNT_dec(temp);
3384  fail:
3385     PUSHi(retval + arybase);
3386     RETURN;
3387 }
3388
3389 PP(pp_sprintf)
3390 {
3391     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3392     if (SvTAINTED(MARK[1]))
3393         TAINT_PROPER("sprintf");
3394     do_sprintf(TARG, SP-MARK, MARK+1);
3395     TAINT_IF(SvTAINTED(TARG));
3396     SP = ORIGMARK;
3397     PUSHTARG;
3398     RETURN;
3399 }
3400
3401 PP(pp_ord)
3402 {
3403     dVAR; dSP; dTARGET;
3404
3405     SV *argsv = POPs;
3406     STRLEN len;
3407     const U8 *s = (U8*)SvPV_const(argsv, len);
3408
3409     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3410         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3411         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3412         argsv = tmpsv;
3413     }
3414
3415     XPUSHu(DO_UTF8(argsv) ?
3416            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3417            (UV)(*s & 0xff));
3418
3419     RETURN;
3420 }
3421
3422 PP(pp_chr)
3423 {
3424     dVAR; dSP; dTARGET;
3425     char *tmps;
3426     UV value;
3427
3428     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3429          ||
3430          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3431         if (IN_BYTES) {
3432             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3433         } else {
3434             (void) POPs; /* Ignore the argument value. */
3435             value = UNICODE_REPLACEMENT;
3436         }
3437     } else {
3438         value = POPu;
3439     }
3440
3441     SvUPGRADE(TARG,SVt_PV);
3442
3443     if (value > 255 && !IN_BYTES) {
3444         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3445         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3446         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3447         *tmps = '\0';
3448         (void)SvPOK_only(TARG);
3449         SvUTF8_on(TARG);
3450         XPUSHs(TARG);
3451         RETURN;
3452     }
3453
3454     SvGROW(TARG,2);
3455     SvCUR_set(TARG, 1);
3456     tmps = SvPVX(TARG);
3457     *tmps++ = (char)value;
3458     *tmps = '\0';
3459     (void)SvPOK_only(TARG);
3460
3461     if (PL_encoding && !IN_BYTES) {
3462         sv_recode_to_utf8(TARG, PL_encoding);
3463         tmps = SvPVX(TARG);
3464         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3465             UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3466             SvGROW(TARG, 2);
3467             tmps = SvPVX(TARG);
3468             SvCUR_set(TARG, 1);
3469             *tmps++ = (char)value;
3470             *tmps = '\0';
3471             SvUTF8_off(TARG);
3472         }
3473     }
3474
3475     XPUSHs(TARG);
3476     RETURN;
3477 }
3478
3479 PP(pp_crypt)
3480 {
3481 #ifdef HAS_CRYPT
3482     dVAR; dSP; dTARGET;
3483     dPOPTOPssrl;
3484     STRLEN len;
3485     const char *tmps = SvPV_const(left, len);
3486
3487     if (DO_UTF8(left)) {
3488          /* If Unicode, try to downgrade.
3489           * If not possible, croak.
3490           * Yes, we made this up.  */
3491          SV* const tsv = sv_2mortal(newSVsv(left));
3492
3493          SvUTF8_on(tsv);
3494          sv_utf8_downgrade(tsv, FALSE);
3495          tmps = SvPV_const(tsv, len);
3496     }
3497 #   ifdef USE_ITHREADS
3498 #     ifdef HAS_CRYPT_R
3499     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3500       /* This should be threadsafe because in ithreads there is only
3501        * one thread per interpreter.  If this would not be true,
3502        * we would need a mutex to protect this malloc. */
3503         PL_reentrant_buffer->_crypt_struct_buffer =
3504           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3505 #if defined(__GLIBC__) || defined(__EMX__)
3506         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3507             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3508             /* work around glibc-2.2.5 bug */
3509             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3510         }
3511 #endif
3512     }
3513 #     endif /* HAS_CRYPT_R */
3514 #   endif /* USE_ITHREADS */
3515 #   ifdef FCRYPT
3516     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3517 #   else
3518     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3519 #   endif
3520     SETTARG;
3521     RETURN;
3522 #else
3523     DIE(aTHX_
3524       "The crypt() function is unimplemented due to excessive paranoia.");
3525 #endif
3526 }
3527
3528 PP(pp_ucfirst)
3529 {
3530     dVAR;
3531     dSP;
3532     SV *source = TOPs;
3533     STRLEN slen;
3534     STRLEN need;
3535     SV *dest;
3536     bool inplace = TRUE;
3537     bool doing_utf8;
3538     const int op_type = PL_op->op_type;
3539     const U8 *s;
3540     U8 *d;
3541     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3542     STRLEN ulen;
3543     STRLEN tculen;
3544
3545     SvGETMAGIC(source);
3546     if (SvOK(source)) {
3547         s = (const U8*)SvPV_nomg_const(source, slen);
3548     } else {
3549         if (ckWARN(WARN_UNINITIALIZED))
3550             report_uninit(source);
3551         s = (const U8*)"";
3552         slen = 0;
3553     }
3554
3555     if (slen && DO_UTF8(source) && UTF8_IS_START(*s)) {
3556         doing_utf8 = TRUE;
3557         utf8_to_uvchr(s, &ulen);
3558         if (op_type == OP_UCFIRST) {
3559             toTITLE_utf8(s, tmpbuf, &tculen);
3560         } else {
3561             toLOWER_utf8(s, tmpbuf, &tculen);
3562         }
3563         /* If the two differ, we definately cannot do inplace.  */
3564         inplace = (ulen == tculen);
3565         need = slen + 1 - ulen + tculen;
3566     } else {
3567         doing_utf8 = FALSE;
3568         need = slen + 1;
3569     }
3570
3571     if (SvPADTMP(source) && !SvREADONLY(source) && inplace && SvTEMP(source)) {
3572         /* We can convert in place.  */
3573
3574         dest = source;
3575         s = d = (U8*)SvPV_force_nomg(source, slen);
3576     } else {
3577         dTARGET;
3578
3579         dest = TARG;
3580
3581         SvUPGRADE(dest, SVt_PV);
3582         d = (U8*)SvGROW(dest, need);
3583         (void)SvPOK_only(dest);
3584
3585         SETs(dest);
3586
3587         inplace = FALSE;
3588     }
3589
3590     if (doing_utf8) {
3591         if(!inplace) {
3592             /* slen is the byte length of the whole SV.
3593              * ulen is the byte length of the original Unicode character
3594              * stored as UTF-8 at s.
3595              * tculen is the byte length of the freshly titlecased (or
3596              * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3597              * We first set the result to be the titlecased (/lowercased)
3598              * character, and then append the rest of the SV data. */
3599             sv_setpvn(dest, (char*)tmpbuf, tculen);
3600             if (slen > ulen)
3601                 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3602             SvUTF8_on(dest);
3603         }
3604         else {
3605             Copy(tmpbuf, d, tculen, U8);
3606             SvCUR_set(dest, need - 1);
3607         }
3608     }
3609     else {
3610         if (*s) {
3611             if (IN_LOCALE_RUNTIME) {
3612                 TAINT;
3613                 SvTAINTED_on(dest);
3614                 *d = (op_type == OP_UCFIRST)
3615                     ? toUPPER_LC(*s) : toLOWER_LC(*s);
3616             }
3617             else
3618                 *d = (op_type == OP_UCFIRST) ? toUPPER(*s) : toLOWER(*s);
3619         } else {
3620             /* See bug #39028  */
3621             *d = *s;
3622         }
3623
3624         if (SvUTF8(source))
3625             SvUTF8_on(dest);
3626
3627         if (!inplace) {
3628             /* This will copy the trailing NUL  */
3629             Copy(s + 1, d + 1, slen, U8);
3630             SvCUR_set(dest, need - 1);
3631         }
3632     }
3633     SvSETMAGIC(dest);
3634     RETURN;
3635 }
3636
3637 /* There's so much setup/teardown code common between uc and lc, I wonder if
3638    it would be worth merging the two, and just having a switch outside each
3639    of the three tight loops.  */
3640 PP(pp_uc)
3641 {
3642     dVAR;
3643     dSP;
3644     SV *source = TOPs;
3645     STRLEN len;
3646     STRLEN min;
3647     SV *dest;
3648     const U8 *s;
3649     U8 *d;
3650
3651     SvGETMAGIC(source);
3652
3653     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3654         && SvTEMP(source) && !DO_UTF8(source)) {
3655         /* We can convert in place.  */
3656
3657         dest = source;
3658         s = d = (U8*)SvPV_force_nomg(source, len);
3659         min = len + 1;
3660     } else {
3661         dTARGET;
3662
3663         dest = TARG;
3664
3665         /* The old implementation would copy source into TARG at this point.
3666            This had the side effect that if source was undef, TARG was now
3667            an undefined SV with PADTMP set, and they don't warn inside
3668            sv_2pv_flags(). However, we're now getting the PV direct from
3669            source, which doesn't have PADTMP set, so it would warn. Hence the
3670            little games.  */
3671
3672         if (SvOK(source)) {
3673             s = (const U8*)SvPV_nomg_const(source, len);
3674         } else {
3675             if (ckWARN(WARN_UNINITIALIZED))
3676                 report_uninit(source);
3677             s = (const U8*)"";
3678             len = 0;
3679         }
3680         min = len + 1;
3681
3682         SvUPGRADE(dest, SVt_PV);
3683         d = (U8*)SvGROW(dest, min);
3684         (void)SvPOK_only(dest);
3685
3686         SETs(dest);
3687     }
3688
3689     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3690        to check DO_UTF8 again here.  */
3691
3692     if (DO_UTF8(source)) {
3693         const U8 *const send = s + len;
3694         U8 tmpbuf[UTF8_MAXBYTES+1];
3695
3696         while (s < send) {
3697             const STRLEN u = UTF8SKIP(s);
3698             STRLEN ulen;
3699
3700             toUPPER_utf8(s, tmpbuf, &ulen);
3701             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3702                 /* If the eventually required minimum size outgrows
3703                  * the available space, we need to grow. */
3704                 const UV o = d - (U8*)SvPVX_const(dest);
3705
3706                 /* If someone uppercases one million U+03B0s we SvGROW() one
3707                  * million times.  Or we could try guessing how much to
3708                  allocate without allocating too much.  Such is life. */
3709                 SvGROW(dest, min);
3710                 d = (U8*)SvPVX(dest) + o;
3711             }
3712             Copy(tmpbuf, d, ulen, U8);
3713             d += ulen;
3714             s += u;
3715         }
3716         SvUTF8_on(dest);
3717         *d = '\0';
3718         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3719     } else {
3720         if (len) {
3721             const U8 *const send = s + len;
3722             if (IN_LOCALE_RUNTIME) {
3723                 TAINT;
3724                 SvTAINTED_on(dest);
3725                 for (; s < send; d++, s++)
3726                     *d = toUPPER_LC(*s);
3727             }
3728             else {
3729                 for (; s < send; d++, s++)
3730                     *d = toUPPER(*s);
3731             }
3732         }
3733         if (source != dest) {
3734             *d = '\0';
3735             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3736         }
3737     }
3738     SvSETMAGIC(dest);
3739     RETURN;
3740 }
3741
3742 PP(pp_lc)
3743 {
3744     dVAR;
3745     dSP;
3746     SV *source = TOPs;
3747     STRLEN len;
3748     STRLEN min;
3749     SV *dest;
3750     const U8 *s;
3751     U8 *d;
3752
3753     SvGETMAGIC(source);
3754
3755     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3756         && SvTEMP(source) && !DO_UTF8(source)) {
3757         /* We can convert in place.  */
3758
3759         dest = source;
3760         s = d = (U8*)SvPV_force_nomg(source, len);
3761         min = len + 1;
3762     } else {
3763         dTARGET;
3764
3765         dest = TARG;
3766
3767         /* The old implementation would copy source into TARG at this point.
3768            This had the side effect that if source was undef, TARG was now
3769            an undefined SV with PADTMP set, and they don't warn inside
3770            sv_2pv_flags(). However, we're now getting the PV direct from
3771            source, which doesn't have PADTMP set, so it would warn. Hence the
3772            little games.  */
3773
3774         if (SvOK(source)) {
3775             s = (const U8*)SvPV_nomg_const(source, len);
3776         } else {
3777             if (ckWARN(WARN_UNINITIALIZED))
3778                 report_uninit(source);
3779             s = (const U8*)"";
3780             len = 0;
3781         }
3782         min = len + 1;
3783
3784         SvUPGRADE(dest, SVt_PV);
3785         d = (U8*)SvGROW(dest, min);
3786         (void)SvPOK_only(dest);
3787
3788         SETs(dest);
3789     }
3790
3791     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3792        to check DO_UTF8 again here.  */
3793
3794     if (DO_UTF8(source)) {
3795         const U8 *const send = s + len;
3796         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3797
3798         while (s < send) {
3799             const STRLEN u = UTF8SKIP(s);
3800             STRLEN ulen;
3801             const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3802
3803 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3804             if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3805                 NOOP;
3806                 /*
3807                  * Now if the sigma is NOT followed by
3808                  * /$ignorable_sequence$cased_letter/;
3809                  * and it IS preceded by /$cased_letter$ignorable_sequence/;
3810                  * where $ignorable_sequence is [\x{2010}\x{AD}\p{Mn}]*
3811                  * and $cased_letter is [\p{Ll}\p{Lo}\p{Lt}]
3812                  * then it should be mapped to 0x03C2,
3813                  * (GREEK SMALL LETTER FINAL SIGMA),
3814                  * instead of staying 0x03A3.
3815                  * "should be": in other words, this is not implemented yet.
3816                  * See lib/unicore/SpecialCasing.txt.
3817                  */
3818             }
3819             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3820                 /* If the eventually required minimum size outgrows
3821                  * the available space, we need to grow. */
3822                 const UV o = d - (U8*)SvPVX_const(dest);
3823
3824                 /* If someone lowercases one million U+0130s we SvGROW() one
3825                  * million times.  Or we could try guessing how much to
3826                  allocate without allocating too much.  Such is life. */
3827                 SvGROW(dest, min);
3828                 d = (U8*)SvPVX(dest) + o;
3829             }
3830             Copy(tmpbuf, d, ulen, U8);
3831             d += ulen;
3832             s += u;
3833         }
3834         SvUTF8_on(dest);
3835         *d = '\0';
3836         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3837     } else {
3838         if (len) {
3839             const U8 *const send = s + len;
3840             if (IN_LOCALE_RUNTIME) {
3841                 TAINT;
3842                 SvTAINTED_on(dest);
3843                 for (; s < send; d++, s++)
3844                     *d = toLOWER_LC(*s);
3845             }
3846             else {
3847                 for (; s < send; d++, s++)
3848                     *d = toLOWER(*s);
3849             }
3850         }
3851         if (source != dest) {
3852             *d = '\0';
3853             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3854         }
3855     }
3856     SvSETMAGIC(dest);
3857     RETURN;
3858 }
3859
3860 PP(pp_quotemeta)
3861 {
3862     dVAR; dSP; dTARGET;
3863     SV * const sv = TOPs;
3864     STRLEN len;
3865     register const char *s = SvPV_const(sv,len);
3866
3867     SvUTF8_off(TARG);                           /* decontaminate */
3868     if (len) {
3869         register char *d;
3870         SvUPGRADE(TARG, SVt_PV);
3871         SvGROW(TARG, (len * 2) + 1);
3872         d = SvPVX(TARG);
3873         if (DO_UTF8(sv)) {
3874             while (len) {
3875                 if (UTF8_IS_CONTINUED(*s)) {
3876                     STRLEN ulen = UTF8SKIP(s);
3877                     if (ulen > len)
3878                         ulen = len;
3879                     len -= ulen;
3880                     while (ulen--)
3881                         *d++ = *s++;
3882                 }
3883                 else {
3884                     if (!isALNUM(*s))
3885                         *d++ = '\\';
3886                     *d++ = *s++;
3887                     len--;
3888                 }
3889             }
3890             SvUTF8_on(TARG);
3891         }
3892         else {
3893             while (len--) {
3894                 if (!isALNUM(*s))
3895                     *d++ = '\\';
3896                 *d++ = *s++;
3897             }
3898         }
3899         *d = '\0';
3900         SvCUR_set(TARG, d - SvPVX_const(TARG));
3901         (void)SvPOK_only_UTF8(TARG);
3902     }
3903     else
3904         sv_setpvn(TARG, s, len);
3905     SETTARG;
3906     RETURN;
3907 }
3908
3909 /* Arrays. */
3910
3911 PP(pp_aslice)
3912 {
3913     dVAR; dSP; dMARK; dORIGMARK;
3914     register AV *const av = MUTABLE_AV(POPs);
3915     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3916
3917     if (SvTYPE(av) == SVt_PVAV) {
3918         const I32 arybase = CopARYBASE_get(PL_curcop);
3919         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3920         bool can_preserve = FALSE;
3921
3922         if (localizing) {
3923             MAGIC *mg;
3924             HV *stash;
3925
3926             can_preserve = SvCANEXISTDELETE(av);
3927         }
3928
3929         if (lval && localizing) {
3930             register SV **svp;
3931             I32 max = -1;
3932             for (svp = MARK + 1; svp <= SP; svp++) {
3933                 const I32 elem = SvIV(*svp);
3934                 if (elem > max)
3935                     max = elem;
3936             }
3937             if (max > AvMAX(av))
3938                 av_extend(av, max);
3939         }
3940
3941         while (++MARK <= SP) {
3942             register SV **svp;
3943             I32 elem = SvIV(*MARK);
3944             bool preeminent = TRUE;
3945
3946             if (elem > 0)
3947                 elem -= arybase;
3948             if (localizing && can_preserve) {
3949                 /* If we can determine whether the element exist,
3950                  * Try to preserve the existenceness of a tied array
3951                  * element by using EXISTS and DELETE if possible.
3952                  * Fallback to FETCH and STORE otherwise. */
3953                 preeminent = av_exists(av, elem);
3954             }
3955
3956             svp = av_fetch(av, elem, lval);
3957             if (lval) {
3958                 if (!svp || *svp == &PL_sv_undef)
3959                     DIE(aTHX_ PL_no_aelem, elem);
3960                 if (localizing) {
3961                     if (preeminent)
3962                         save_aelem(av, elem, svp);
3963                     else
3964                         SAVEADELETE(av, elem);
3965                 }
3966             }
3967             *MARK = svp ? *svp : &PL_sv_undef;
3968         }
3969     }
3970     if (GIMME != G_ARRAY) {
3971         MARK = ORIGMARK;
3972         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3973         SP = MARK;
3974     }
3975     RETURN;
3976 }
3977
3978 PP(pp_aeach)
3979 {
3980     dVAR;
3981     dSP;
3982     AV *array = MUTABLE_AV(POPs);
3983     const I32 gimme = GIMME_V;
3984     IV *iterp = Perl_av_iter_p(aTHX_ array);
3985     const IV current = (*iterp)++;
3986
3987     if (current > av_len(array)) {
3988         *iterp = 0;
3989         if (gimme == G_SCALAR)
3990             RETPUSHUNDEF;
3991         else
3992             RETURN;
3993     }
3994
3995     EXTEND(SP, 2);
3996     mPUSHi(CopARYBASE_get(PL_curcop) + current);
3997     if (gimme == G_ARRAY) {
3998         SV **const element = av_fetch(array, current, 0);
3999         PUSHs(element ? *element : &PL_sv_undef);
4000     }
4001     RETURN;
4002 }
4003
4004 PP(pp_akeys)
4005 {
4006     dVAR;
4007     dSP;
4008     AV *array = MUTABLE_AV(POPs);
4009     const I32 gimme = GIMME_V;
4010
4011     *Perl_av_iter_p(aTHX_ array) = 0;
4012
4013     if (gimme == G_SCALAR) {
4014         dTARGET;
4015         PUSHi(av_len(array) + 1);
4016     }
4017     else if (gimme == G_ARRAY) {
4018         IV n = Perl_av_len(aTHX_ array);
4019         IV i = CopARYBASE_get(PL_curcop);
4020
4021         EXTEND(SP, n + 1);
4022
4023         if (PL_op->op_type == OP_AKEYS) {
4024             n += i;
4025             for (;  i <= n;  i++) {
4026                 mPUSHi(i);
4027             }
4028         }
4029         else {
4030             for (i = 0;  i <= n;  i++) {
4031                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4032                 PUSHs(elem ? *elem : &PL_sv_undef);
4033             }
4034         }
4035     }
4036     RETURN;
4037 }
4038
4039 /* Associative arrays. */
4040
4041 PP(pp_each)
4042 {
4043     dVAR;
4044     dSP;
4045     HV * hash = MUTABLE_HV(POPs);
4046     HE *entry;
4047     const I32 gimme = GIMME_V;
4048
4049     PUTBACK;
4050     /* might clobber stack_sp */
4051     entry = hv_iternext(hash);
4052     SPAGAIN;
4053
4054     EXTEND(SP, 2);
4055     if (entry) {
4056         SV* const sv = hv_iterkeysv(entry);
4057         PUSHs(sv);      /* won't clobber stack_sp */
4058         if (gimme == G_ARRAY) {
4059             SV *val;
4060             PUTBACK;
4061             /* might clobber stack_sp */
4062             val = hv_iterval(hash, entry);
4063             SPAGAIN;
4064             PUSHs(val);
4065         }
4066     }
4067     else if (gimme == G_SCALAR)
4068         RETPUSHUNDEF;
4069
4070     RETURN;
4071 }
4072
4073 STATIC OP *
4074 S_do_delete_local(pTHX)
4075 {
4076     dVAR;
4077     dSP;
4078     const I32 gimme = GIMME_V;
4079     const MAGIC *mg;
4080     HV *stash;
4081
4082     if (PL_op->op_private & OPpSLICE) {
4083         dMARK; dORIGMARK;
4084         SV * const osv = POPs;
4085         const bool tied = SvRMAGICAL(osv)
4086                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4087         const bool can_preserve = SvCANEXISTDELETE(osv)
4088                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4089         const U32 type = SvTYPE(osv);
4090         if (type == SVt_PVHV) {                 /* hash element */
4091             HV * const hv = MUTABLE_HV(osv);
4092             while (++MARK <= SP) {
4093                 SV * const keysv = *MARK;
4094                 SV *sv = NULL;
4095                 bool preeminent = TRUE;
4096                 if (can_preserve)
4097                     preeminent = hv_exists_ent(hv, keysv, 0);
4098                 if (tied) {
4099                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4100                     if (he)
4101                         sv = HeVAL(he);
4102                     else
4103                         preeminent = FALSE;
4104                 }
4105                 else {
4106                     sv = hv_delete_ent(hv, keysv, 0, 0);
4107                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4108                 }
4109                 if (preeminent) {
4110                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4111                     if (tied) {
4112                         *MARK = sv_mortalcopy(sv);
4113                         mg_clear(sv);
4114                     } else
4115                         *MARK = sv;
4116                 }
4117                 else {
4118                     SAVEHDELETE(hv, keysv);
4119                     *MARK = &PL_sv_undef;
4120                 }
4121             }
4122         }
4123         else if (type == SVt_PVAV) {                  /* array element */
4124             if (PL_op->op_flags & OPf_SPECIAL) {
4125                 AV * const av = MUTABLE_AV(osv);
4126                 while (++MARK <= SP) {
4127                     I32 idx = SvIV(*MARK);
4128                     SV *sv = NULL;
4129                     bool preeminent = TRUE;
4130                     if (can_preserve)
4131                         preeminent = av_exists(av, idx);
4132                     if (tied) {
4133                         SV **svp = av_fetch(av, idx, 1);
4134                         if (svp)
4135                             sv = *svp;
4136                         else
4137                             preeminent = FALSE;
4138                     }
4139                     else {
4140                         sv = av_delete(av, idx, 0);
4141                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4142                     }
4143                     if (preeminent) {
4144                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4145                         if (tied) {
4146                             *MARK = sv_mortalcopy(sv);
4147                             mg_clear(sv);
4148                         } else
4149                             *MARK = sv;
4150                     }
4151                     else {
4152                         SAVEADELETE(av, idx);
4153                         *MARK = &PL_sv_undef;
4154                     }
4155                 }
4156             }
4157         }
4158         else
4159             DIE(aTHX_ "Not a HASH reference");
4160         if (gimme == G_VOID)
4161             SP = ORIGMARK;
4162         else if (gimme == G_SCALAR) {
4163             MARK = ORIGMARK;
4164             if (SP > MARK)
4165                 *++MARK = *SP;
4166             else
4167                 *++MARK = &PL_sv_undef;
4168             SP = MARK;
4169         }
4170     }
4171     else {
4172         SV * const keysv = POPs;
4173         SV * const osv   = POPs;
4174         const bool tied = SvRMAGICAL(osv)
4175                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4176         const bool can_preserve = SvCANEXISTDELETE(osv)
4177                                     || mg_find((const SV *)osv, PERL_MAGIC_env);
4178         const U32 type = SvTYPE(osv);
4179         SV *sv = NULL;
4180         if (type == SVt_PVHV) {
4181             HV * const hv = MUTABLE_HV(osv);
4182             bool preeminent = TRUE;
4183             if (can_preserve)
4184                 preeminent = hv_exists_ent(hv, keysv, 0);
4185             if (tied) {
4186                 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4187                 if (he)
4188                     sv = HeVAL(he);
4189                 else
4190                     preeminent = FALSE;
4191             }
4192             else {
4193                 sv = hv_delete_ent(hv, keysv, 0, 0);
4194                 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4195             }
4196             if (preeminent) {
4197                 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4198                 if (tied) {
4199                     SV *nsv = sv_mortalcopy(sv);
4200                     mg_clear(sv);
4201                     sv = nsv;
4202                 }
4203             }
4204             else
4205                 SAVEHDELETE(hv, keysv);
4206         }
4207         else if (type == SVt_PVAV) {
4208             if (PL_op->op_flags & OPf_SPECIAL) {
4209                 AV * const av = MUTABLE_AV(osv);
4210                 I32 idx = SvIV(keysv);
4211                 bool preeminent = TRUE;
4212                 if (can_preserve)
4213                     preeminent = av_exists(av, idx);
4214                 if (tied) {
4215                     SV **svp = av_fetch(av, idx, 1);
4216                     if (svp)
4217                         sv = *svp;
4218                     else
4219                         preeminent = FALSE;
4220                 }
4221                 else {
4222                     sv = av_delete(av, idx, 0);
4223                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4224                 }
4225                 if (preeminent) {
4226                     save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4227                     if (tied) {
4228                         SV *nsv = sv_mortalcopy(sv);
4229                         mg_clear(sv);
4230                         sv = nsv;
4231                     }
4232                 }
4233                 else
4234                     SAVEADELETE(av, idx);
4235             }
4236             else
4237                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4238         }
4239         else
4240             DIE(aTHX_ "Not a HASH reference");
4241         if (!sv)
4242             sv = &PL_sv_undef;
4243         if (gimme != G_VOID)
4244             PUSHs(sv);
4245     }
4246
4247     RETURN;
4248 }
4249
4250 PP(pp_delete)
4251 {
4252     dVAR;
4253     dSP;
4254     I32 gimme;
4255     I32 discard;
4256
4257     if (PL_op->op_private & OPpLVAL_INTRO)
4258         return do_delete_local();
4259
4260     gimme = GIMME_V;
4261     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4262
4263     if (PL_op->op_private & OPpSLICE) {
4264         dMARK; dORIGMARK;
4265         HV * const hv = MUTABLE_HV(POPs);
4266         const U32 hvtype = SvTYPE(hv);
4267         if (hvtype == SVt_PVHV) {                       /* hash element */
4268             while (++MARK <= SP) {
4269                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4270                 *MARK = sv ? sv : &PL_sv_undef;
4271             }
4272         }
4273         else if (hvtype == SVt_PVAV) {                  /* array element */
4274             if (PL_op->op_flags & OPf_SPECIAL) {
4275                 while (++MARK <= SP) {
4276                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4277                     *MARK = sv ? sv : &PL_sv_undef;
4278                 }
4279             }
4280         }
4281         else
4282             DIE(aTHX_ "Not a HASH reference");
4283         if (discard)
4284             SP = ORIGMARK;
4285         else if (gimme == G_SCALAR) {
4286             MARK = ORIGMARK;
4287             if (SP > MARK)
4288                 *++MARK = *SP;
4289             else
4290                 *++MARK = &PL_sv_undef;
4291             SP = MARK;
4292         }
4293     }
4294     else {
4295         SV *keysv = POPs;
4296         HV * const hv = MUTABLE_HV(POPs);
4297         SV *sv;
4298         if (SvTYPE(hv) == SVt_PVHV)
4299             sv = hv_delete_ent(hv, keysv, discard, 0);
4300         else if (SvTYPE(hv) == SVt_PVAV) {
4301             if (PL_op->op_flags & OPf_SPECIAL)
4302                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4303             else
4304                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4305         }
4306         else
4307             DIE(aTHX_ "Not a HASH reference");
4308         if (!sv)
4309             sv = &PL_sv_undef;
4310         if (!discard)
4311             PUSHs(sv);
4312     }
4313     RETURN;
4314 }
4315
4316 PP(pp_exists)
4317 {
4318     dVAR;
4319     dSP;
4320     SV *tmpsv;
4321     HV *hv;
4322
4323     if (PL_op->op_private & OPpEXISTS_SUB) {
4324         GV *gv;
4325         SV * const sv = POPs;
4326         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4327         if (cv)
4328             RETPUSHYES;
4329         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4330             RETPUSHYES;
4331         RETPUSHNO;
4332     }
4333     tmpsv = POPs;
4334     hv = MUTABLE_HV(POPs);
4335     if (SvTYPE(hv) == SVt_PVHV) {
4336         if (hv_exists_ent(hv, tmpsv, 0))
4337             RETPUSHYES;
4338     }
4339     else if (SvTYPE(hv) == SVt_PVAV) {
4340         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4341             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4342                 RETPUSHYES;
4343         }
4344     }
4345     else {
4346         DIE(aTHX_ "Not a HASH reference");
4347     }
4348     RETPUSHNO;
4349 }
4350
4351 PP(pp_hslice)
4352 {
4353     dVAR; dSP; dMARK; dORIGMARK;
4354     register HV * const hv = MUTABLE_HV(POPs);
4355     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4356     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4357     bool can_preserve = FALSE;
4358
4359     if (localizing) {
4360         MAGIC *mg;
4361         HV *stash;
4362
4363         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4364             can_preserve = TRUE;
4365     }
4366
4367     while (++MARK <= SP) {
4368         SV * const keysv = *MARK;
4369         SV **svp;
4370         HE *he;
4371         bool preeminent = TRUE;
4372
4373         if (localizing && can_preserve) {
4374             /* If we can determine whether the element exist,
4375              * try to preserve the existenceness of a tied hash
4376              * element by using EXISTS and DELETE if possible.
4377              * Fallback to FETCH and STORE otherwise. */
4378             preeminent = hv_exists_ent(hv, keysv, 0);
4379         }
4380
4381         he = hv_fetch_ent(hv, keysv, lval, 0);
4382         svp = he ? &HeVAL(he) : NULL;
4383
4384         if (lval) {
4385             if (!svp || *svp == &PL_sv_undef) {
4386                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4387             }
4388             if (localizing) {
4389                 if (HvNAME_get(hv) && isGV(*svp))
4390                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4391                 else if (preeminent)
4392                     save_helem_flags(hv, keysv, svp,
4393                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4394                 else
4395                     SAVEHDELETE(hv, keysv);
4396             }
4397         }
4398         *MARK = svp ? *svp : &PL_sv_undef;
4399     }
4400     if (GIMME != G_ARRAY) {
4401         MARK = ORIGMARK;
4402         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4403         SP = MARK;
4404     }
4405     RETURN;
4406 }
4407
4408 /* List operators. */
4409
4410 PP(pp_list)
4411 {
4412     dVAR; dSP; dMARK;
4413     if (GIMME != G_ARRAY) {
4414         if (++MARK <= SP)
4415             *MARK = *SP;                /* unwanted list, return last item */
4416         else
4417             *MARK = &PL_sv_undef;
4418         SP = MARK;
4419     }
4420     RETURN;
4421 }
4422
4423 PP(pp_lslice)
4424 {
4425     dVAR;
4426     dSP;
4427     SV ** const lastrelem = PL_stack_sp;
4428     SV ** const lastlelem = PL_stack_base + POPMARK;
4429     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4430     register SV ** const firstrelem = lastlelem + 1;
4431     const I32 arybase = CopARYBASE_get(PL_curcop);
4432     I32 is_something_there = FALSE;
4433
4434     register const I32 max = lastrelem - lastlelem;
4435     register SV **lelem;
4436
4437     if (GIMME != G_ARRAY) {
4438         I32 ix = SvIV(*lastlelem);
4439         if (ix < 0)
4440             ix += max;
4441         else
4442             ix -= arybase;
4443         if (ix < 0 || ix >= max)
4444             *firstlelem = &PL_sv_undef;
4445         else
4446             *firstlelem = firstrelem[ix];
4447         SP = firstlelem;
4448         RETURN;
4449     }
4450
4451     if (max == 0) {
4452         SP = firstlelem - 1;
4453         RETURN;
4454     }
4455
4456     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4457         I32 ix = SvIV(*lelem);
4458         if (ix < 0)
4459             ix += max;
4460         else
4461             ix -= arybase;
4462         if (ix < 0 || ix >= max)
4463             *lelem = &PL_sv_undef;
4464         else {
4465             is_something_there = TRUE;
4466             if (!(*lelem = firstrelem[ix]))
4467                 *lelem = &PL_sv_undef;
4468         }
4469     }
4470     if (is_something_there)
4471         SP = lastlelem;
4472     else
4473         SP = firstlelem - 1;
4474     RETURN;
4475 }
4476
4477 PP(pp_anonlist)
4478 {
4479     dVAR; dSP; dMARK; dORIGMARK;
4480     const I32 items = SP - MARK;
4481     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4482     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4483     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4484             ? newRV_noinc(av) : av);
4485     RETURN;
4486 }
4487
4488 PP(pp_anonhash)
4489 {
4490     dVAR; dSP; dMARK; dORIGMARK;
4491     HV* const hv = newHV();
4492
4493     while (MARK < SP) {
4494         SV * const key = *++MARK;
4495         SV * const val = newSV(0);
4496         if (MARK < SP)
4497             sv_setsv(val, *++MARK);
4498         else
4499             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4500         (void)hv_store_ent(hv,key,val,0);
4501     }
4502     SP = ORIGMARK;
4503     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4504             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4505     RETURN;
4506 }
4507
4508 PP(pp_splice)
4509 {
4510     dVAR; dSP; dMARK; dORIGMARK;
4511     register AV *ary = MUTABLE_AV(*++MARK);
4512     register SV **src;
4513     register SV **dst;
4514     register I32 i;
4515     register I32 offset;
4516     register I32 length;
4517     I32 newlen;
4518     I32 after;
4519     I32 diff;
4520     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4521
4522     if (mg) {
4523         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4524         PUSHMARK(MARK);
4525         PUTBACK;
4526         ENTER;
4527         call_method("SPLICE",GIMME_V);
4528         LEAVE;
4529         SPAGAIN;
4530         RETURN;
4531     }
4532
4533     SP++;
4534
4535     if (++MARK < SP) {
4536         offset = i = SvIV(*MARK);
4537         if (offset < 0)
4538             offset += AvFILLp(ary) + 1;
4539         else
4540             offset -= CopARYBASE_get(PL_curcop);
4541         if (offset < 0)
4542             DIE(aTHX_ PL_no_aelem, i);
4543         if (++MARK < SP) {
4544             length = SvIVx(*MARK++);
4545             if (length < 0) {
4546                 length += AvFILLp(ary) - offset + 1;
4547                 if (length < 0)
4548                     length = 0;
4549             }
4550         }
4551         else
4552             length = AvMAX(ary) + 1;            /* close enough to infinity */
4553     }
4554     else {
4555         offset = 0;
4556         length = AvMAX(ary) + 1;
4557     }
4558     if (offset > AvFILLp(ary) + 1) {
4559         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4560         offset = AvFILLp(ary) + 1;
4561     }
4562     after = AvFILLp(ary) + 1 - (offset + length);
4563     if (after < 0) {                            /* not that much array */
4564         length += after;                        /* offset+length now in array */
4565         after = 0;
4566         if (!AvALLOC(ary))
4567             av_extend(ary, 0);
4568     }
4569
4570     /* At this point, MARK .. SP-1 is our new LIST */
4571
4572     newlen = SP - MARK;
4573     diff = newlen - length;
4574     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4575         av_reify(ary);
4576
4577     /* make new elements SVs now: avoid problems if they're from the array */
4578     for (dst = MARK, i = newlen; i; i--) {
4579         SV * const h = *dst;
4580         *dst++ = newSVsv(h);
4581     }
4582
4583     if (diff < 0) {                             /* shrinking the area */
4584         SV **tmparyval = NULL;
4585         if (newlen) {
4586             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4587             Copy(MARK, tmparyval, newlen, SV*);
4588         }
4589
4590         MARK = ORIGMARK + 1;
4591         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4592             MEXTEND(MARK, length);
4593             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4594             if (AvREAL(ary)) {
4595                 EXTEND_MORTAL(length);
4596                 for (i = length, dst = MARK; i; i--) {
4597                     sv_2mortal(*dst);   /* free them eventualy */
4598                     dst++;
4599                 }
4600             }
4601             MARK += length - 1;
4602         }
4603         else {
4604             *MARK = AvARRAY(ary)[offset+length-1];
4605             if (AvREAL(ary)) {
4606                 sv_2mortal(*MARK);
4607                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4608                     SvREFCNT_dec(*dst++);       /* free them now */
4609             }
4610         }
4611         AvFILLp(ary) += diff;
4612
4613         /* pull up or down? */
4614
4615         if (offset < after) {                   /* easier to pull up */
4616             if (offset) {                       /* esp. if nothing to pull */
4617                 src = &AvARRAY(ary)[offset-1];
4618                 dst = src - diff;               /* diff is negative */
4619                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4620                     *dst-- = *src--;
4621             }
4622             dst = AvARRAY(ary);
4623             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4624             AvMAX(ary) += diff;
4625         }
4626         else {
4627             if (after) {                        /* anything to pull down? */
4628                 src = AvARRAY(ary) + offset + length;
4629                 dst = src + diff;               /* diff is negative */
4630                 Move(src, dst, after, SV*);
4631             }
4632             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4633                                                 /* avoid later double free */
4634         }
4635         i = -diff;
4636         while (i)
4637             dst[--i] = &PL_sv_undef;
4638
4639         if (newlen) {
4640             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4641             Safefree(tmparyval);
4642         }
4643     }
4644     else {                                      /* no, expanding (or same) */
4645         SV** tmparyval = NULL;
4646         if (length) {
4647             Newx(tmparyval, length, SV*);       /* so remember deletion */
4648             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4649         }
4650
4651         if (diff > 0) {                         /* expanding */
4652             /* push up or down? */
4653             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4654                 if (offset) {
4655                     src = AvARRAY(ary);
4656                     dst = src - diff;
4657                     Move(src, dst, offset, SV*);
4658                 }
4659                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4660                 AvMAX(ary) += diff;
4661                 AvFILLp(ary) += diff;
4662             }
4663             else {
4664                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4665                     av_extend(ary, AvFILLp(ary) + diff);
4666                 AvFILLp(ary) += diff;
4667
4668                 if (after) {
4669                     dst = AvARRAY(ary) + AvFILLp(ary);
4670                     src = dst - diff;
4671                     for (i = after; i; i--) {
4672                         *dst-- = *src--;
4673                     }
4674                 }
4675             }
4676         }
4677
4678         if (newlen) {
4679             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4680         }
4681
4682         MARK = ORIGMARK + 1;
4683         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4684             if (length) {
4685                 Copy(tmparyval, MARK, length, SV*);
4686                 if (AvREAL(ary)) {
4687                     EXTEND_MORTAL(length);
4688                     for (i = length, dst = MARK; i; i--) {
4689                         sv_2mortal(*dst);       /* free them eventualy */
4690                         dst++;
4691                     }
4692                 }
4693             }
4694             MARK += length - 1;
4695         }
4696         else if (length--) {
4697             *MARK = tmparyval[length];
4698             if (AvREAL(ary)) {
4699                 sv_2mortal(*MARK);
4700                 while (length-- > 0)
4701                     SvREFCNT_dec(tmparyval[length]);
4702             }
4703         }
4704         else
4705             *MARK = &PL_sv_undef;
4706         Safefree(tmparyval);
4707     }
4708     SP = MARK;
4709     RETURN;
4710 }
4711
4712 PP(pp_push)
4713 {
4714     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4715     register AV * const ary = MUTABLE_AV(*++MARK);
4716     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4717
4718     if (mg) {
4719         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4720         PUSHMARK(MARK);
4721         PUTBACK;
4722         ENTER;
4723         call_method("PUSH",G_SCALAR|G_DISCARD);
4724         LEAVE;
4725         SPAGAIN;
4726     }
4727     else {
4728         PL_delaymagic = DM_DELAY;
4729         for (++MARK; MARK <= SP; MARK++) {
4730             SV * const sv = newSV(0);
4731             if (*MARK)
4732                 sv_setsv(sv, *MARK);
4733             av_store(ary, AvFILLp(ary)+1, sv);
4734         }
4735         if (PL_delaymagic & DM_ARRAY)
4736             mg_set(MUTABLE_SV(ary));
4737
4738         PL_delaymagic = 0;
4739     }
4740     SP = ORIGMARK;
4741     if (OP_GIMME(PL_op, 0) != G_VOID) {
4742         PUSHi( AvFILL(ary) + 1 );
4743     }
4744     RETURN;
4745 }
4746
4747 PP(pp_shift)
4748 {
4749     dVAR;
4750     dSP;
4751     AV * const av = MUTABLE_AV(POPs);
4752     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4753     EXTEND(SP, 1);
4754     assert (sv);
4755     if (AvREAL(av))
4756         (void)sv_2mortal(sv);
4757     PUSHs(sv);
4758     RETURN;
4759 }
4760
4761 PP(pp_unshift)
4762 {
4763     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4764     register AV *ary = MUTABLE_AV(*++MARK);
4765     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4766
4767     if (mg) {
4768         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4769         PUSHMARK(MARK);
4770         PUTBACK;
4771         ENTER;
4772         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4773         LEAVE;
4774         SPAGAIN;
4775     }
4776     else {
4777         register I32 i = 0;
4778         av_unshift(ary, SP - MARK);
4779         while (MARK < SP) {
4780             SV * const sv = newSVsv(*++MARK);
4781             (void)av_store(ary, i++, sv);
4782         }
4783     }
4784     SP = ORIGMARK;
4785     if (OP_GIMME(PL_op, 0) != G_VOID) {
4786         PUSHi( AvFILL(ary) + 1 );
4787     }
4788     RETURN;
4789 }
4790
4791 PP(pp_reverse)
4792 {
4793     dVAR; dSP; dMARK;
4794
4795     if (GIMME == G_ARRAY) {
4796         if (PL_op->op_private & OPpREVERSE_INPLACE) {
4797             AV *av;
4798
4799             /* See pp_sort() */
4800             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
4801             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
4802             av = MUTABLE_AV((*SP));
4803             /* In-place reversing only happens in void context for the array
4804              * assignment. We don't need to push anything on the stack. */
4805             SP = MARK;
4806
4807             if (SvMAGICAL(av)) {
4808                 I32 i, j;
4809                 register SV *tmp = sv_newmortal();
4810                 /* For SvCANEXISTDELETE */
4811                 HV *stash;
4812                 const MAGIC *mg;
4813                 bool can_preserve = SvCANEXISTDELETE(av);
4814
4815                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
4816                     register SV *begin, *end;
4817
4818                     if (can_preserve) {
4819                         if (!av_exists(av, i)) {
4820                             if (av_exists(av, j)) {
4821                                 register SV *sv = av_delete(av, j, 0);
4822                                 begin = *av_fetch(av, i, TRUE);
4823                                 sv_setsv_mg(begin, sv);
4824                             }
4825                             continue;
4826                         }
4827                         else if (!av_exists(av, j)) {
4828                             register SV *sv = av_delete(av, i, 0);
4829                             end = *av_fetch(av, j, TRUE);
4830                             sv_setsv_mg(end, sv);
4831                             continue;
4832                         }
4833                     }
4834
4835                     begin = *av_fetch(av, i, TRUE);
4836                     end   = *av_fetch(av, j, TRUE);
4837                     sv_setsv(tmp,      begin);
4838                     sv_setsv_mg(begin, end);
4839                     sv_setsv_mg(end,   tmp);
4840                 }
4841             }
4842             else {
4843                 SV **begin = AvARRAY(av);
4844                 SV **end   = begin + AvFILLp(av);
4845
4846                 while (begin < end) {
4847                     register SV * const tmp = *begin;
4848                     *begin++ = *end;
4849                     *end--   = tmp;
4850                 }
4851             }
4852         }
4853         else {
4854             SV **oldsp = SP;
4855             MARK++;
4856             while (MARK < SP) {
4857                 register SV * const tmp = *MARK;
4858                 *MARK++ = *SP;
4859                 *SP--   = tmp;
4860             }
4861             /* safe as long as stack cannot get extended in the above */
4862             SP = oldsp;
4863         }
4864     }
4865     else {
4866         register char *up;
4867         register char *down;
4868         register I32 tmp;
4869         dTARGET;
4870         STRLEN len;
4871         PADOFFSET padoff_du;
4872
4873         SvUTF8_off(TARG);                               /* decontaminate */
4874         if (SP - MARK > 1)
4875             do_join(TARG, &PL_sv_no, MARK, SP);
4876         else {
4877             sv_setsv(TARG, (SP > MARK)
4878                     ? *SP
4879                     : (padoff_du = find_rundefsvoffset(),
4880                         (padoff_du == NOT_IN_PAD
4881                          || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4882                         ? DEFSV : PAD_SVl(padoff_du)));
4883
4884             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
4885                 report_uninit(TARG);
4886         }
4887
4888         up = SvPV_force(TARG, len);
4889         if (len > 1) {
4890             if (DO_UTF8(TARG)) {        /* first reverse each character */
4891                 U8* s = (U8*)SvPVX(TARG);
4892                 const U8* send = (U8*)(s + len);
4893                 while (s < send) {
4894                     if (UTF8_IS_INVARIANT(*s)) {
4895                         s++;
4896                         continue;
4897                     }
4898                     else {
4899                         if (!utf8_to_uvchr(s, 0))
4900                             break;
4901                         up = (char*)s;
4902                         s += UTF8SKIP(s);
4903                         down = (char*)(s - 1);
4904                         /* reverse this character */
4905                         while (down > up) {
4906                             tmp = *up;
4907                             *up++ = *down;
4908                             *down-- = (char)tmp;
4909                         }
4910                     }
4911                 }
4912                 up = SvPVX(TARG);
4913             }
4914             down = SvPVX(TARG) + len - 1;
4915             while (down > up) {
4916                 tmp = *up;
4917                 *up++ = *down;
4918                 *down-- = (char)tmp;
4919             }
4920             (void)SvPOK_only_UTF8(TARG);
4921         }
4922         SP = MARK + 1;
4923         SETTARG;
4924     }
4925     RETURN;
4926 }
4927
4928 PP(pp_split)
4929 {
4930     dVAR; dSP; dTARG;
4931     AV *ary;
4932     register IV limit = POPi;                   /* note, negative is forever */
4933     SV * const sv = POPs;
4934     STRLEN len;
4935     register const char *s = SvPV_const(sv, len);
4936     const bool do_utf8 = DO_UTF8(sv);
4937     const char *strend = s + len;
4938     register PMOP *pm;
4939     register REGEXP *rx;
4940     register SV *dstr;
4941     register const char *m;
4942     I32 iters = 0;
4943     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
4944     I32 maxiters = slen + 10;
4945     I32 trailing_empty = 0;
4946     const char *orig;
4947     const I32 origlimit = limit;
4948     I32 realarray = 0;
4949     I32 base;
4950     const I32 gimme = GIMME_V;
4951     bool gimme_scalar;
4952     const I32 oldsave = PL_savestack_ix;
4953     U32 make_mortal = SVs_TEMP;
4954     bool multiline = 0;
4955     MAGIC *mg = NULL;
4956
4957 #ifdef DEBUGGING
4958     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4959 #else
4960     pm = (PMOP*)POPs;
4961 #endif
4962     if (!pm || !s)
4963         DIE(aTHX_ "panic: pp_split");
4964     rx = PM_GETRE(pm);
4965
4966     TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
4967              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
4968
4969     RX_MATCH_UTF8_set(rx, do_utf8);
4970
4971 #ifdef USE_ITHREADS
4972     if (pm->op_pmreplrootu.op_pmtargetoff) {
4973         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
4974     }
4975 #else
4976     if (pm->op_pmreplrootu.op_pmtargetgv) {
4977         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
4978     }
4979 #endif
4980     else
4981         ary = NULL;
4982     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4983         realarray = 1;
4984         PUTBACK;
4985         av_extend(ary,0);
4986         av_clear(ary);
4987         SPAGAIN;
4988         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
4989             PUSHMARK(SP);
4990             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
4991         }
4992         else {
4993             if (!AvREAL(ary)) {
4994                 I32 i;
4995                 AvREAL_on(ary);
4996                 AvREIFY_off(ary);
4997                 for (i = AvFILLp(ary); i >= 0; i--)
4998                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4999             }
5000             /* temporarily switch stacks */
5001             SAVESWITCHSTACK(PL_curstack, ary);
5002             make_mortal = 0;
5003         }
5004     }
5005     base = SP - PL_stack_base;
5006     orig = s;
5007     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5008         if (do_utf8) {
5009             while (*s == ' ' || is_utf8_space((U8*)s))
5010                 s += UTF8SKIP(s);
5011         }
5012         else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5013             while (isSPACE_LC(*s))
5014                 s++;
5015         }
5016         else {
5017             while (isSPACE(*s))
5018                 s++;
5019         }
5020     }
5021     if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5022         multiline = 1;
5023     }
5024
5025     gimme_scalar = gimme == G_SCALAR && !ary;
5026
5027     if (!limit)
5028         limit = maxiters + 2;
5029     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5030         while (--limit) {
5031             m = s;
5032             /* this one uses 'm' and is a negative test */
5033             if (do_utf8) {
5034                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5035                     const int t = UTF8SKIP(m);
5036                     /* is_utf8_space returns FALSE for malform utf8 */
5037                     if (strend - m < t)
5038                         m = strend;
5039                     else
5040                         m += t;
5041                 }
5042             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5043                 while (m < strend && !isSPACE_LC(*m))
5044                     ++m;
5045             } else {
5046                 while (m < strend && !isSPACE(*m))
5047                     ++m;
5048             }
5049             if (m >= strend)
5050                 break;
5051
5052             if (gimme_scalar) {
5053                 iters++;
5054                 if (m-s == 0)
5055                     trailing_empty++;
5056                 else
5057                     trailing_empty = 0;
5058             } else {
5059                 dstr = newSVpvn_flags(s, m-s,
5060                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5061                 XPUSHs(dstr);
5062             }
5063
5064             /* skip the whitespace found last */
5065             if (do_utf8)
5066                 s = m + UTF8SKIP(m);
5067             else
5068                 s = m + 1;
5069
5070             /* this one uses 's' and is a positive test */
5071             if (do_utf8) {
5072                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5073                     s +=  UTF8SKIP(s);
5074             } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5075                 while (s < strend && isSPACE_LC(*s))
5076                     ++s;
5077             } else {
5078                 while (s < strend && isSPACE(*s))
5079                     ++s;
5080             }
5081         }
5082     }
5083     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5084         while (--limit) {
5085             for (m = s; m < strend && *m != '\n'; m++)
5086                 ;
5087             m++;
5088             if (m >= strend)
5089                 break;
5090
5091             if (gimme_scalar) {
5092                 iters++;
5093                 if (m-s == 0)
5094                     trailing_empty++;
5095                 else
5096                     trailing_empty = 0;
5097             } else {
5098                 dstr = newSVpvn_flags(s, m-s,
5099                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5100                 XPUSHs(dstr);
5101             }
5102             s = m;
5103         }
5104     }
5105     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5106         /*
5107           Pre-extend the stack, either the number of bytes or
5108           characters in the string or a limited amount, triggered by:
5109
5110           my ($x, $y) = split //, $str;
5111             or
5112           split //, $str, $i;
5113         */
5114         if (!gimme_scalar) {
5115             const U32 items = limit - 1;
5116             if (items < slen)
5117                 EXTEND(SP, items);
5118             else
5119                 EXTEND(SP, slen);
5120         }
5121
5122         if (do_utf8) {
5123             while (--limit) {
5124                 /* keep track of how many bytes we skip over */
5125                 m = s;
5126                 s += UTF8SKIP(s);
5127                 if (gimme_scalar) {
5128                     iters++;
5129                     if (s-m == 0)
5130                         trailing_empty++;
5131                     else
5132                         trailing_empty = 0;
5133                 } else {
5134                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5135
5136                     PUSHs(dstr);
5137                 }
5138
5139                 if (s >= strend)
5140                     break;
5141             }
5142         } else {
5143             while (--limit) {
5144                 if (gimme_scalar) {
5145                     iters++;
5146                 } else {
5147                     dstr = newSVpvn(s, 1);
5148
5149
5150                     if (make_mortal)
5151                         sv_2mortal(dstr);
5152
5153                     PUSHs(dstr);
5154                 }
5155
5156                 s++;
5157
5158                 if (s >= strend)
5159                     break;
5160             }
5161         }
5162     }
5163     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5164              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5165              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5166              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5167         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5168         SV * const csv = CALLREG_INTUIT_STRING(rx);
5169
5170         len = RX_MINLENRET(rx);
5171         if (len == 1 && !RX_UTF8(rx) && !tail) {
5172             const char c = *SvPV_nolen_const(csv);
5173             while (--limit) {
5174                 for (m = s; m < strend && *m != c; m++)
5175                     ;
5176                 if (m >= strend)
5177                     break;
5178                 if (gimme_scalar) {
5179                     iters++;
5180                     if (m-s == 0)
5181                         trailing_empty++;
5182                     else
5183                         trailing_empty = 0;
5184                 } else {
5185                     dstr = newSVpvn_flags(s, m-s,
5186                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5187                     XPUSHs(dstr);
5188                 }
5189                 /* The rx->minlen is in characters but we want to step
5190                  * s ahead by bytes. */
5191                 if (do_utf8)
5192                     s = (char*)utf8_hop((U8*)m, len);
5193                 else
5194                     s = m + len; /* Fake \n at the end */
5195             }
5196         }
5197         else {
5198             while (s < strend && --limit &&
5199               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5200                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5201             {
5202                 if (gimme_scalar) {
5203                     iters++;
5204                     if (m-s == 0)
5205                         trailing_empty++;
5206                     else
5207                         trailing_empty = 0;
5208                 } else {
5209                     dstr = newSVpvn_flags(s, m-s,
5210                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5211                     XPUSHs(dstr);
5212                 }
5213                 /* The rx->minlen is in characters but we want to step
5214                  * s ahead by bytes. */
5215                 if (do_utf8)
5216                     s = (char*)utf8_hop((U8*)m, len);
5217                 else
5218                     s = m + len; /* Fake \n at the end */
5219             }
5220         }
5221     }
5222     else {
5223         maxiters += slen * RX_NPARENS(rx);
5224         while (s < strend && --limit)
5225         {
5226             I32 rex_return;
5227             PUTBACK;
5228             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5229                             sv, NULL, 0);
5230             SPAGAIN;
5231             if (rex_return == 0)
5232                 break;
5233             TAINT_IF(RX_MATCH_TAINTED(rx));
5234             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5235                 m = s;
5236                 s = orig;
5237                 orig = RX_SUBBEG(rx);
5238                 s = orig + (m - s);
5239                 strend = s + (strend - m);
5240             }
5241             m = RX_OFFS(rx)[0].start + orig;
5242
5243             if (gimme_scalar) {
5244                 iters++;
5245                 if (m-s == 0)
5246                     trailing_empty++;
5247                 else
5248                     trailing_empty = 0;
5249             } else {
5250                 dstr = newSVpvn_flags(s, m-s,
5251                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5252                 XPUSHs(dstr);
5253             }
5254             if (RX_NPARENS(rx)) {
5255                 I32 i;
5256                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5257                     s = RX_OFFS(rx)[i].start + orig;
5258                     m = RX_OFFS(rx)[i].end + orig;
5259
5260                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5261                        parens that didn't match -- they should be set to
5262                        undef, not the empty string */
5263                     if (gimme_scalar) {
5264                         iters++;
5265                         if (m-s == 0)
5266                             trailing_empty++;
5267                         else
5268                             trailing_empty = 0;
5269                     } else {
5270                         if (m >= orig && s >= orig) {
5271                             dstr = newSVpvn_flags(s, m-s,
5272                                                  (do_utf8 ? SVf_UTF8 : 0)
5273                                                   | make_mortal);
5274                         }
5275                         else
5276                             dstr = &PL_sv_undef;  /* undef, not "" */
5277                         XPUSHs(dstr);
5278                     }
5279
5280                 }
5281             }
5282             s = RX_OFFS(rx)[0].end + orig;
5283         }
5284     }
5285
5286     if (!gimme_scalar) {
5287         iters = (SP - PL_stack_base) - base;
5288     }
5289     if (iters > maxiters)
5290         DIE(aTHX_ "Split loop");
5291
5292     /* keep field after final delim? */
5293     if (s < strend || (iters && origlimit)) {
5294         if (!gimme_scalar) {
5295             const STRLEN l = strend - s;
5296             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5297             XPUSHs(dstr);
5298         }
5299         iters++;
5300     }
5301     else if (!origlimit) {
5302         if (gimme_scalar) {
5303             iters -= trailing_empty;
5304         } else {
5305             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5306                 if (TOPs && !make_mortal)
5307                     sv_2mortal(TOPs);
5308                 *SP-- = &PL_sv_undef;
5309                 iters--;
5310             }
5311         }
5312     }
5313
5314     PUTBACK;
5315     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5316     SPAGAIN;
5317     if (realarray) {
5318         if (!mg) {
5319             if (SvSMAGICAL(ary)) {
5320                 PUTBACK;
5321                 mg_set(MUTABLE_SV(ary));
5322                 SPAGAIN;
5323             }
5324             if (gimme == G_ARRAY) {
5325                 EXTEND(SP, iters);
5326                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5327                 SP += iters;
5328                 RETURN;
5329             }
5330         }
5331         else {
5332             PUTBACK;
5333             ENTER;
5334             call_method("PUSH",G_SCALAR|G_DISCARD);
5335             LEAVE;
5336             SPAGAIN;
5337             if (gimme == G_ARRAY) {
5338                 I32 i;
5339                 /* EXTEND should not be needed - we just popped them */
5340                 EXTEND(SP, iters);
5341                 for (i=0; i < iters; i++) {
5342                     SV **svp = av_fetch(ary, i, FALSE);
5343                     PUSHs((svp) ? *svp : &PL_sv_undef);
5344                 }
5345                 RETURN;
5346             }
5347         }
5348     }
5349     else {
5350         if (gimme == G_ARRAY)
5351             RETURN;
5352     }
5353
5354     GETTARGET;
5355     PUSHi(iters);
5356     RETURN;
5357 }
5358
5359 PP(pp_once)
5360 {
5361     dSP;
5362     SV *const sv = PAD_SVl(PL_op->op_targ);
5363
5364     if (SvPADSTALE(sv)) {
5365         /* First time. */
5366         SvPADSTALE_off(sv);
5367         RETURNOP(cLOGOP->op_other);
5368     }
5369     RETURNOP(cLOGOP->op_next);
5370 }
5371
5372 PP(pp_lock)
5373 {
5374     dVAR;
5375     dSP;
5376     dTOPss;
5377     SV *retsv = sv;
5378     assert(SvTYPE(retsv) != SVt_PVCV);
5379     SvLOCK(sv);
5380     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
5381         retsv = refto(retsv);
5382     }
5383     SETs(retsv);
5384     RETURN;
5385 }
5386
5387
5388 PP(unimplemented_op)
5389 {
5390     dVAR;
5391     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
5392         PL_op->op_type);
5393     return NORMAL;
5394 }
5395
5396 PP(pp_boolkeys)
5397 {
5398     dVAR;
5399     dSP;
5400     HV * const hv = (HV*)POPs;
5401
5402     if (SvRMAGICAL(hv)) {
5403         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5404         if (mg) {
5405             XPUSHs(magic_scalarpack(hv, mg));
5406             RETURN;
5407         }
5408     }
5409
5410     XPUSHs(boolSV(HvKEYS(hv) != 0));
5411     RETURN;
5412 }
5413
5414 /*
5415  * Local variables:
5416  * c-indentation-style: bsd
5417  * c-basic-offset: 4
5418  * indent-tabs-mode: t
5419  * End:
5420  *
5421  * ex: set ts=8 sts=4 sw=4 noet:
5422  */