pp.c

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