pp.c

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