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