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