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