pp.c

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