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 = (SvPV_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 = SvPV_const(tsv, len);
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 = (SvPV_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 = SvPV_const(tsv, len);
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_const(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                     SvPV_force_nolen(sv);
3125                     if (ckWARN(WARN_SUBSTR))
3126                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3127                                 "Attempt to use reference as lvalue in substr");
3128                 }
3129                 if (SvOK(sv))           /* is it defined ? */
3130                     (void)SvPOK_only_UTF8(sv);
3131                 else
3132                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3133             }
3134
3135             if (SvTYPE(TARG) < SVt_PVLV) {
3136                 sv_upgrade(TARG, SVt_PVLV);
3137                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3138             }
3139             else
3140                 SvOK_off(TARG);
3141
3142             LvTYPE(TARG) = 'x';
3143             if (LvTARG(TARG) != sv) {
3144                 if (LvTARG(TARG))
3145                     SvREFCNT_dec(LvTARG(TARG));
3146                 LvTARG(TARG) = SvREFCNT_inc(sv);
3147             }
3148             LvTARGOFF(TARG) = upos;
3149             LvTARGLEN(TARG) = urem;
3150         }
3151     }
3152     SPAGAIN;
3153     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3154     RETURN;
3155 }
3156
3157 PP(pp_vec)
3158 {
3159     dSP; dTARGET;
3160     register IV size   = POPi;
3161     register IV offset = POPi;
3162     register SV *src = POPs;
3163     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3164
3165     SvTAINTED_off(TARG);                /* decontaminate */
3166     if (lvalue) {                       /* it's an lvalue! */
3167         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3168             TARG = sv_newmortal();
3169         if (SvTYPE(TARG) < SVt_PVLV) {
3170             sv_upgrade(TARG, SVt_PVLV);
3171             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3172         }
3173         LvTYPE(TARG) = 'v';
3174         if (LvTARG(TARG) != src) {
3175             if (LvTARG(TARG))
3176                 SvREFCNT_dec(LvTARG(TARG));
3177             LvTARG(TARG) = SvREFCNT_inc(src);
3178         }
3179         LvTARGOFF(TARG) = offset;
3180         LvTARGLEN(TARG) = size;
3181     }
3182
3183     sv_setuv(TARG, do_vecget(src, offset, size));
3184     PUSHs(TARG);
3185     RETURN;
3186 }
3187
3188 PP(pp_index)
3189 {
3190     dSP; dTARGET;
3191     SV *big;
3192     SV *little;
3193     SV *temp = Nullsv;
3194     I32 offset;
3195     I32 retval;
3196     const char *tmps;
3197     const char *tmps2;
3198     STRLEN biglen;
3199     I32 arybase = PL_curcop->cop_arybase;
3200     int big_utf8;
3201     int little_utf8;
3202
3203     if (MAXARG < 3)
3204         offset = 0;
3205     else
3206         offset = POPi - arybase;
3207     little = POPs;
3208     big = POPs;
3209     big_utf8 = DO_UTF8(big);
3210     little_utf8 = DO_UTF8(little);
3211     if (big_utf8 ^ little_utf8) {
3212         /* One needs to be upgraded.  */
3213         SV *bytes = little_utf8 ? big : little;
3214         STRLEN len;
3215         const char *p = SvPV_const(bytes, len);
3216
3217         temp = newSVpvn(p, len);
3218
3219         if (PL_encoding) {
3220             sv_recode_to_utf8(temp, PL_encoding);
3221         } else {
3222             sv_utf8_upgrade(temp);
3223         }
3224         if (little_utf8) {
3225             big = temp;
3226             big_utf8 = TRUE;
3227         } else {
3228             little = temp;
3229         }
3230     }
3231     if (big_utf8 && offset > 0)
3232         sv_pos_u2b(big, &offset, 0);
3233     tmps = SvPV_const(big, biglen);
3234     if (offset < 0)
3235         offset = 0;
3236     else if (offset > (I32)biglen)
3237         offset = biglen;
3238     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3239       (unsigned char*)tmps + biglen, little, 0)))
3240         retval = -1;
3241     else
3242         retval = tmps2 - tmps;
3243     if (retval > 0 && big_utf8)
3244         sv_pos_b2u(big, &retval);
3245     if (temp)
3246         SvREFCNT_dec(temp);
3247     PUSHi(retval + arybase);
3248     RETURN;
3249 }
3250
3251 PP(pp_rindex)
3252 {
3253     dSP; dTARGET;
3254     SV *big;
3255     SV *little;
3256     SV *temp = Nullsv;
3257     STRLEN blen;
3258     STRLEN llen;
3259     I32 offset;
3260     I32 retval;
3261     const char *tmps;
3262     const char *tmps2;
3263     I32 arybase = PL_curcop->cop_arybase;
3264     int big_utf8;
3265     int little_utf8;
3266
3267     if (MAXARG >= 3)
3268         offset = POPi;
3269     little = POPs;
3270     big = POPs;
3271     big_utf8 = DO_UTF8(big);
3272     little_utf8 = DO_UTF8(little);
3273     if (big_utf8 ^ little_utf8) {
3274         /* One needs to be upgraded.  */
3275         SV *bytes = little_utf8 ? big : little;
3276         STRLEN len;
3277         const char *p = SvPV_const(bytes, len);
3278
3279         temp = newSVpvn(p, len);
3280
3281         if (PL_encoding) {
3282             sv_recode_to_utf8(temp, PL_encoding);
3283         } else {
3284             sv_utf8_upgrade(temp);
3285         }
3286         if (little_utf8) {
3287             big = temp;
3288             big_utf8 = TRUE;
3289         } else {
3290             little = temp;
3291         }
3292     }
3293     tmps2 = SvPV_const(little, llen);
3294     tmps = SvPV_const(big, blen);
3295
3296     if (MAXARG < 3)
3297         offset = blen;
3298     else {
3299         if (offset > 0 && big_utf8)
3300             sv_pos_u2b(big, &offset, 0);
3301         offset = offset - arybase + llen;
3302     }
3303     if (offset < 0)
3304         offset = 0;
3305     else if (offset > (I32)blen)
3306         offset = blen;
3307     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3308                           tmps2, tmps2 + llen)))
3309         retval = -1;
3310     else
3311         retval = tmps2 - tmps;
3312     if (retval > 0 && big_utf8)
3313         sv_pos_b2u(big, &retval);
3314     if (temp)
3315         SvREFCNT_dec(temp);
3316     PUSHi(retval + arybase);
3317     RETURN;
3318 }
3319
3320 PP(pp_sprintf)
3321 {
3322     dSP; dMARK; dORIGMARK; dTARGET;
3323     do_sprintf(TARG, SP-MARK, MARK+1);
3324     TAINT_IF(SvTAINTED(TARG));
3325     if (DO_UTF8(*(MARK+1)))
3326         SvUTF8_on(TARG);
3327     SP = ORIGMARK;
3328     PUSHTARG;
3329     RETURN;
3330 }
3331
3332 PP(pp_ord)
3333 {
3334     dSP; dTARGET;
3335     SV *argsv = POPs;
3336     STRLEN len;
3337     const U8 *s = (U8*)SvPV_const(argsv, len);
3338     SV *tmpsv;
3339
3340     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3341         tmpsv = sv_2mortal(newSVsv(argsv));
3342         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3343         argsv = tmpsv;
3344     }
3345
3346     XPUSHu(DO_UTF8(argsv) ?
3347            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3348            (*s & 0xff));
3349
3350     RETURN;
3351 }
3352
3353 PP(pp_chr)
3354 {
3355     dSP; dTARGET;
3356     char *tmps;
3357     UV value;
3358
3359     if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3360          ||
3361          (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3362         if (IN_BYTES) {
3363             value = POPu; /* chr(-1) eq chr(0xff), etc. */
3364         } else {
3365             (void) POPs; /* Ignore the argument value. */
3366             value = UNICODE_REPLACEMENT;
3367         }
3368     } else {
3369         value = POPu;
3370     }
3371
3372     SvUPGRADE(TARG,SVt_PV);
3373
3374     if (value > 255 && !IN_BYTES) {
3375         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3376         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3377         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3378         *tmps = '\0';
3379         (void)SvPOK_only(TARG);
3380         SvUTF8_on(TARG);
3381         XPUSHs(TARG);
3382         RETURN;
3383     }
3384
3385     SvGROW(TARG,2);
3386     SvCUR_set(TARG, 1);
3387     tmps = SvPVX(TARG);
3388     *tmps++ = (char)value;
3389     *tmps = '\0';
3390     (void)SvPOK_only(TARG);
3391     if (PL_encoding && !IN_BYTES) {
3392         sv_recode_to_utf8(TARG, PL_encoding);
3393         tmps = SvPVX(TARG);
3394         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3395             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3396             SvGROW(TARG, 3);
3397             tmps = SvPVX(TARG);
3398             SvCUR_set(TARG, 2);
3399             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3400             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3401             *tmps = '\0';
3402             SvUTF8_on(TARG);
3403         }
3404     }
3405     XPUSHs(TARG);
3406     RETURN;
3407 }
3408
3409 PP(pp_crypt)
3410 {
3411 #ifdef HAS_CRYPT
3412     dSP; dTARGET;
3413     dPOPTOPssrl;
3414     STRLEN len;
3415     const char *tmps = SvPV_const(left, len);
3416
3417     if (DO_UTF8(left)) {
3418          /* If Unicode, try to downgrade.
3419           * If not possible, croak.
3420           * Yes, we made this up.  */
3421          SV* tsv = sv_2mortal(newSVsv(left));
3422
3423          SvUTF8_on(tsv);
3424          sv_utf8_downgrade(tsv, FALSE);
3425          tmps = SvPV_const(tsv, len);
3426     }
3427 #   ifdef USE_ITHREADS
3428 #     ifdef HAS_CRYPT_R
3429     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3430       /* This should be threadsafe because in ithreads there is only
3431        * one thread per interpreter.  If this would not be true,
3432        * we would need a mutex to protect this malloc. */
3433         PL_reentrant_buffer->_crypt_struct_buffer =
3434           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3435 #if defined(__GLIBC__) || defined(__EMX__)
3436         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3437             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3438             /* work around glibc-2.2.5 bug */
3439             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3440         }
3441 #endif
3442     }
3443 #     endif /* HAS_CRYPT_R */
3444 #   endif /* USE_ITHREADS */
3445 #   ifdef FCRYPT
3446     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3447 #   else
3448     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3449 #   endif
3450     SETs(TARG);
3451     RETURN;
3452 #else
3453     DIE(aTHX_
3454       "The crypt() function is unimplemented due to excessive paranoia.");
3455 #endif
3456 }
3457
3458 PP(pp_ucfirst)
3459 {
3460     dSP;
3461     SV *sv = TOPs;
3462     const U8 *s;
3463     STRLEN slen;
3464
3465     SvGETMAGIC(sv);
3466     if (DO_UTF8(sv) &&
3467         (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3468         UTF8_IS_START(*s)) {
3469         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3470         STRLEN ulen;
3471         STRLEN tculen;
3472
3473         utf8_to_uvchr(s, &ulen);
3474         toTITLE_utf8(s, tmpbuf, &tculen);
3475         utf8_to_uvchr(tmpbuf, 0);
3476
3477         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3478             dTARGET;
3479             /* slen is the byte length of the whole SV.
3480              * ulen is the byte length of the original Unicode character
3481              * stored as UTF-8 at s.
3482              * tculen is the byte length of the freshly titlecased
3483              * Unicode character stored as UTF-8 at tmpbuf.
3484              * We first set the result to be the titlecased character,
3485              * and then append the rest of the SV data. */
3486             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3487             if (slen > ulen)
3488                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3489             SvUTF8_on(TARG);
3490             SETs(TARG);
3491         }
3492         else {
3493             s = (U8*)SvPV_force_nomg(sv, slen);
3494             Copy(tmpbuf, s, tculen, U8);
3495         }
3496     }
3497     else {
3498         U8 *s1;
3499         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3500             dTARGET;
3501             SvUTF8_off(TARG);                           /* decontaminate */
3502             sv_setsv_nomg(TARG, sv);
3503             sv = TARG;
3504             SETs(sv);
3505         }
3506         s1 = (U8*)SvPV_force_nomg(sv, slen);
3507         if (*s1) {
3508             if (IN_LOCALE_RUNTIME) {
3509                 TAINT;
3510                 SvTAINTED_on(sv);
3511                 *s1 = toUPPER_LC(*s1);
3512             }
3513             else
3514                 *s1 = toUPPER(*s1);
3515         }
3516     }
3517     SvSETMAGIC(sv);
3518     RETURN;
3519 }
3520
3521 PP(pp_lcfirst)
3522 {
3523     dSP;
3524     SV *sv = TOPs;
3525     const U8 *s;
3526     STRLEN slen;
3527
3528     SvGETMAGIC(sv);
3529     if (DO_UTF8(sv) &&
3530         (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3531         UTF8_IS_START(*s)) {
3532         STRLEN ulen;
3533         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3534         U8 *tend;
3535         UV uv;
3536
3537         toLOWER_utf8(s, tmpbuf, &ulen);
3538         uv = utf8_to_uvchr(tmpbuf, 0);
3539         tend = uvchr_to_utf8(tmpbuf, uv);
3540
3541         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3542             dTARGET;
3543             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3544             if (slen > ulen)
3545                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3546             SvUTF8_on(TARG);
3547             SETs(TARG);
3548         }
3549         else {
3550             s = (U8*)SvPV_force_nomg(sv, slen);
3551             Copy(tmpbuf, s, ulen, U8);
3552         }
3553     }
3554     else {
3555         U8 *s1;
3556         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3557             dTARGET;
3558             SvUTF8_off(TARG);                           /* decontaminate */
3559             sv_setsv_nomg(TARG, sv);
3560             sv = TARG;
3561             SETs(sv);
3562         }
3563         s1 = (U8*)SvPV_force_nomg(sv, slen);
3564         if (*s1) {
3565             if (IN_LOCALE_RUNTIME) {
3566                 TAINT;
3567                 SvTAINTED_on(sv);
3568                 *s1 = toLOWER_LC(*s1);
3569             }
3570             else
3571                 *s1 = toLOWER(*s1);
3572         }
3573     }
3574     SvSETMAGIC(sv);
3575     RETURN;
3576 }
3577
3578 PP(pp_uc)
3579 {
3580     dSP;
3581     SV *sv = TOPs;
3582     STRLEN len;
3583
3584     SvGETMAGIC(sv);
3585     if (DO_UTF8(sv)) {
3586         dTARGET;
3587         STRLEN ulen;
3588         register U8 *d;
3589         const U8 *s;
3590         const U8 *send;
3591         U8 tmpbuf[UTF8_MAXBYTES+1];
3592
3593         s = (const U8*)SvPV_nomg_const(sv,len);
3594         if (!len) {
3595             SvUTF8_off(TARG);                           /* decontaminate */
3596             sv_setpvn(TARG, "", 0);
3597             SETs(TARG);
3598         }
3599         else {
3600             STRLEN min = len + 1;
3601
3602             SvUPGRADE(TARG, SVt_PV);
3603             SvGROW(TARG, min);
3604             (void)SvPOK_only(TARG);
3605             d = (U8*)SvPVX(TARG);
3606             send = s + len;
3607             while (s < send) {
3608                 STRLEN u = UTF8SKIP(s);
3609
3610                 toUPPER_utf8(s, tmpbuf, &ulen);
3611                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3612                     /* If the eventually required minimum size outgrows
3613                      * the available space, we need to grow. */
3614                     UV o = d - (U8*)SvPVX_const(TARG);
3615
3616                     /* If someone uppercases one million U+03B0s we
3617                      * SvGROW() one million times.  Or we could try
3618                      * guessing how much to allocate without allocating
3619                      * too much. Such is life. */
3620                     SvGROW(TARG, min);
3621                     d = (U8*)SvPVX(TARG) + o;
3622                 }
3623                 Copy(tmpbuf, d, ulen, U8);
3624                 d += ulen;
3625                 s += u;
3626             }
3627             *d = '\0';
3628             SvUTF8_on(TARG);
3629             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3630             SETs(TARG);
3631         }
3632     }
3633     else {
3634         U8 *s;
3635         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3636             dTARGET;
3637             SvUTF8_off(TARG);                           /* decontaminate */
3638             sv_setsv_nomg(TARG, sv);
3639             sv = TARG;
3640             SETs(sv);
3641         }
3642         s = (U8*)SvPV_force_nomg(sv, len);
3643         if (len) {
3644             const register U8 *send = s + len;
3645
3646             if (IN_LOCALE_RUNTIME) {
3647                 TAINT;
3648                 SvTAINTED_on(sv);
3649                 for (; s < send; s++)
3650                     *s = toUPPER_LC(*s);
3651             }
3652             else {
3653                 for (; s < send; s++)
3654                     *s = toUPPER(*s);
3655             }
3656         }
3657     }
3658     SvSETMAGIC(sv);
3659     RETURN;
3660 }
3661
3662 PP(pp_lc)
3663 {
3664     dSP;
3665     SV *sv = TOPs;
3666     STRLEN len;
3667
3668     SvGETMAGIC(sv);
3669     if (DO_UTF8(sv)) {
3670         dTARGET;
3671         const U8 *s;
3672         STRLEN ulen;
3673         register U8 *d;
3674         const U8 *send;
3675         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3676
3677         s = (const U8*)SvPV_nomg_const(sv,len);
3678         if (!len) {
3679             SvUTF8_off(TARG);                           /* decontaminate */
3680             sv_setpvn(TARG, "", 0);
3681             SETs(TARG);
3682         }
3683         else {
3684             STRLEN min = len + 1;
3685
3686             SvUPGRADE(TARG, SVt_PV);
3687             SvGROW(TARG, min);
3688             (void)SvPOK_only(TARG);
3689             d = (U8*)SvPVX(TARG);
3690             send = s + len;
3691             while (s < send) {
3692                 STRLEN u = UTF8SKIP(s);
3693                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3694
3695 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3696                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3697                      /*
3698                       * Now if the sigma is NOT followed by
3699                       * /$ignorable_sequence$cased_letter/;
3700                       * and it IS preceded by
3701                       * /$cased_letter$ignorable_sequence/;
3702                       * where $ignorable_sequence is
3703                       * [\x{2010}\x{AD}\p{Mn}]*
3704                       * and $cased_letter is
3705                       * [\p{Ll}\p{Lo}\p{Lt}]
3706                       * then it should be mapped to 0x03C2,
3707                       * (GREEK SMALL LETTER FINAL SIGMA),
3708                       * instead of staying 0x03A3.
3709                       * "should be": in other words,
3710                       * this is not implemented yet.
3711                       * See lib/unicore/SpecialCasing.txt.
3712                       */
3713                 }
3714                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3715                     /* If the eventually required minimum size outgrows
3716                      * the available space, we need to grow. */
3717                     UV o = d - (U8*)SvPVX_const(TARG);
3718
3719                     /* If someone lowercases one million U+0130s we
3720                      * SvGROW() one million times.  Or we could try
3721                      * guessing how much to allocate without allocating.
3722                      * too much.  Such is life. */
3723                     SvGROW(TARG, min);
3724                     d = (U8*)SvPVX(TARG) + o;
3725                 }
3726                 Copy(tmpbuf, d, ulen, U8);
3727                 d += ulen;
3728                 s += u;
3729             }
3730             *d = '\0';
3731             SvUTF8_on(TARG);
3732             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3733             SETs(TARG);
3734         }
3735     }
3736     else {
3737         U8 *s;
3738         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3739             dTARGET;
3740             SvUTF8_off(TARG);                           /* decontaminate */
3741             sv_setsv_nomg(TARG, sv);
3742             sv = TARG;
3743             SETs(sv);
3744         }
3745
3746         s = (U8*)SvPV_force_nomg(sv, len);
3747         if (len) {
3748             register U8 *send = s + len;
3749
3750             if (IN_LOCALE_RUNTIME) {
3751                 TAINT;
3752                 SvTAINTED_on(sv);
3753                 for (; s < send; s++)
3754                     *s = toLOWER_LC(*s);
3755             }
3756             else {
3757                 for (; s < send; s++)
3758                     *s = toLOWER(*s);
3759             }
3760         }
3761     }
3762     SvSETMAGIC(sv);
3763     RETURN;
3764 }
3765
3766 PP(pp_quotemeta)
3767 {
3768     dSP; dTARGET;
3769     SV *sv = TOPs;
3770     STRLEN len;
3771     const register char *s = SvPV_const(sv,len);
3772     register char *d;
3773
3774     SvUTF8_off(TARG);                           /* decontaminate */
3775     if (len) {
3776         SvUPGRADE(TARG, SVt_PV);
3777         SvGROW(TARG, (len * 2) + 1);
3778         d = SvPVX(TARG);
3779         if (DO_UTF8(sv)) {
3780             while (len) {
3781                 if (UTF8_IS_CONTINUED(*s)) {
3782                     STRLEN ulen = UTF8SKIP(s);
3783                     if (ulen > len)
3784                         ulen = len;
3785                     len -= ulen;
3786                     while (ulen--)
3787                         *d++ = *s++;
3788                 }
3789                 else {
3790                     if (!isALNUM(*s))
3791                         *d++ = '\\';
3792                     *d++ = *s++;
3793                     len--;
3794                 }
3795             }
3796             SvUTF8_on(TARG);
3797         }
3798         else {
3799             while (len--) {
3800                 if (!isALNUM(*s))
3801                     *d++ = '\\';
3802                 *d++ = *s++;
3803             }
3804         }
3805         *d = '\0';
3806         SvCUR_set(TARG, d - SvPVX_const(TARG));
3807         (void)SvPOK_only_UTF8(TARG);
3808     }
3809     else
3810         sv_setpvn(TARG, s, len);
3811     SETs(TARG);
3812     if (SvSMAGICAL(TARG))
3813         mg_set(TARG);
3814     RETURN;
3815 }
3816
3817 /* Arrays. */
3818
3819 PP(pp_aslice)
3820 {
3821     dSP; dMARK; dORIGMARK;
3822     register SV** svp;
3823     register AV* av = (AV*)POPs;
3824     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3825     I32 arybase = PL_curcop->cop_arybase;
3826     I32 elem;
3827
3828     if (SvTYPE(av) == SVt_PVAV) {
3829         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3830             I32 max = -1;
3831             for (svp = MARK + 1; svp <= SP; svp++) {
3832                 elem = SvIVx(*svp);
3833                 if (elem > max)
3834                     max = elem;
3835             }
3836             if (max > AvMAX(av))
3837                 av_extend(av, max);
3838         }
3839         while (++MARK <= SP) {
3840             elem = SvIVx(*MARK);
3841
3842             if (elem > 0)
3843                 elem -= arybase;
3844             svp = av_fetch(av, elem, lval);
3845             if (lval) {
3846                 if (!svp || *svp == &PL_sv_undef)
3847                     DIE(aTHX_ PL_no_aelem, elem);
3848                 if (PL_op->op_private & OPpLVAL_INTRO)
3849                     save_aelem(av, elem, svp);
3850             }
3851             *MARK = svp ? *svp : &PL_sv_undef;
3852         }
3853     }
3854     if (GIMME != G_ARRAY) {
3855         MARK = ORIGMARK;
3856         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3857         SP = MARK;
3858     }
3859     RETURN;
3860 }
3861
3862 /* Associative arrays. */
3863
3864 PP(pp_each)
3865 {
3866     dSP;
3867     HV *hash = (HV*)POPs;
3868     HE *entry;
3869     const I32 gimme = GIMME_V;
3870
3871     PUTBACK;
3872     /* might clobber stack_sp */
3873     entry = hv_iternext(hash);
3874     SPAGAIN;
3875
3876     EXTEND(SP, 2);
3877     if (entry) {
3878         SV* sv = hv_iterkeysv(entry);
3879         PUSHs(sv);      /* won't clobber stack_sp */
3880         if (gimme == G_ARRAY) {
3881             SV *val;
3882             PUTBACK;
3883             /* might clobber stack_sp */
3884             val = hv_iterval(hash, entry);
3885             SPAGAIN;
3886             PUSHs(val);
3887         }
3888     }
3889     else if (gimme == G_SCALAR)
3890         RETPUSHUNDEF;
3891
3892     RETURN;
3893 }
3894
3895 PP(pp_values)
3896 {
3897     return do_kv();
3898 }
3899
3900 PP(pp_keys)
3901 {
3902     return do_kv();
3903 }
3904
3905 PP(pp_delete)
3906 {
3907     dSP;
3908     const I32 gimme = GIMME_V;
3909     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3910     SV *sv;
3911     HV *hv;
3912
3913     if (PL_op->op_private & OPpSLICE) {
3914         dMARK; dORIGMARK;
3915         U32 hvtype;
3916         hv = (HV*)POPs;
3917         hvtype = SvTYPE(hv);
3918         if (hvtype == SVt_PVHV) {                       /* hash element */
3919             while (++MARK <= SP) {
3920                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3921                 *MARK = sv ? sv : &PL_sv_undef;
3922             }
3923         }
3924         else if (hvtype == SVt_PVAV) {                  /* array element */
3925             if (PL_op->op_flags & OPf_SPECIAL) {
3926                 while (++MARK <= SP) {
3927                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3928                     *MARK = sv ? sv : &PL_sv_undef;
3929                 }
3930             }
3931         }
3932         else
3933             DIE(aTHX_ "Not a HASH reference");
3934         if (discard)
3935             SP = ORIGMARK;
3936         else if (gimme == G_SCALAR) {
3937             MARK = ORIGMARK;
3938             if (SP > MARK)
3939                 *++MARK = *SP;
3940             else
3941                 *++MARK = &PL_sv_undef;
3942             SP = MARK;
3943         }
3944     }
3945     else {
3946         SV *keysv = POPs;
3947         hv = (HV*)POPs;
3948         if (SvTYPE(hv) == SVt_PVHV)
3949             sv = hv_delete_ent(hv, keysv, discard, 0);
3950         else if (SvTYPE(hv) == SVt_PVAV) {
3951             if (PL_op->op_flags & OPf_SPECIAL)
3952                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3953             else
3954                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3955         }
3956         else
3957             DIE(aTHX_ "Not a HASH reference");
3958         if (!sv)
3959             sv = &PL_sv_undef;
3960         if (!discard)
3961             PUSHs(sv);
3962     }
3963     RETURN;
3964 }
3965
3966 PP(pp_exists)
3967 {
3968     dSP;
3969     SV *tmpsv;
3970     HV *hv;
3971
3972     if (PL_op->op_private & OPpEXISTS_SUB) {
3973         GV *gv;
3974         CV *cv;
3975         SV *sv = POPs;
3976         cv = sv_2cv(sv, &hv, &gv, FALSE);
3977         if (cv)
3978             RETPUSHYES;
3979         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3980             RETPUSHYES;
3981         RETPUSHNO;
3982     }
3983     tmpsv = POPs;
3984     hv = (HV*)POPs;
3985     if (SvTYPE(hv) == SVt_PVHV) {
3986         if (hv_exists_ent(hv, tmpsv, 0))
3987             RETPUSHYES;
3988     }
3989     else if (SvTYPE(hv) == SVt_PVAV) {
3990         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3991             if (av_exists((AV*)hv, SvIV(tmpsv)))
3992                 RETPUSHYES;
3993         }
3994     }
3995     else {
3996         DIE(aTHX_ "Not a HASH reference");
3997     }
3998     RETPUSHNO;
3999 }
4000
4001 PP(pp_hslice)
4002 {
4003     dSP; dMARK; dORIGMARK;
4004     register HV *hv = (HV*)POPs;
4005     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4006     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
4007     bool other_magic = FALSE;
4008
4009     if (localizing) {
4010         MAGIC *mg;
4011         HV *stash;
4012
4013         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4014             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4015              /* Try to preserve the existenceness of a tied hash
4016               * element by using EXISTS and DELETE if possible.
4017               * Fallback to FETCH and STORE otherwise */
4018              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4019              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4020              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4021     }
4022
4023     while (++MARK <= SP) {
4024         SV *keysv = *MARK;
4025         SV **svp;
4026         HE *he;
4027         bool preeminent = FALSE;
4028
4029         if (localizing) {
4030             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4031                 hv_exists_ent(hv, keysv, 0);
4032         }
4033
4034         he = hv_fetch_ent(hv, keysv, lval, 0);
4035         svp = he ? &HeVAL(he) : 0;
4036
4037         if (lval) {
4038             if (!svp || *svp == &PL_sv_undef) {
4039                 DIE(aTHX_ PL_no_helem_sv, keysv);
4040             }
4041             if (localizing) {
4042                 if (preeminent)
4043                     save_helem(hv, keysv, svp);
4044                 else {
4045                     STRLEN keylen;
4046                     const char *key = SvPV_const(keysv, keylen);
4047                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
4048                 }
4049             }
4050         }
4051         *MARK = svp ? *svp : &PL_sv_undef;
4052     }
4053     if (GIMME != G_ARRAY) {
4054         MARK = ORIGMARK;
4055         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4056         SP = MARK;
4057     }
4058     RETURN;
4059 }
4060
4061 /* List operators. */
4062
4063 PP(pp_list)
4064 {
4065     dSP; dMARK;
4066     if (GIMME != G_ARRAY) {
4067         if (++MARK <= SP)
4068             *MARK = *SP;                /* unwanted list, return last item */
4069         else
4070             *MARK = &PL_sv_undef;
4071         SP = MARK;
4072     }
4073     RETURN;
4074 }
4075
4076 PP(pp_lslice)
4077 {
4078     dSP;
4079     SV **lastrelem = PL_stack_sp;
4080     SV **lastlelem = PL_stack_base + POPMARK;
4081     SV **firstlelem = PL_stack_base + POPMARK + 1;
4082     register SV **firstrelem = lastlelem + 1;
4083     I32 arybase = PL_curcop->cop_arybase;
4084     I32 lval = PL_op->op_flags & OPf_MOD;
4085     I32 is_something_there = lval;
4086
4087     register I32 max = lastrelem - lastlelem;
4088     register SV **lelem;
4089     register I32 ix;
4090
4091     if (GIMME != G_ARRAY) {
4092         ix = SvIVx(*lastlelem);
4093         if (ix < 0)
4094             ix += max;
4095         else
4096             ix -= arybase;
4097         if (ix < 0 || ix >= max)
4098             *firstlelem = &PL_sv_undef;
4099         else
4100             *firstlelem = firstrelem[ix];
4101         SP = firstlelem;
4102         RETURN;
4103     }
4104
4105     if (max == 0) {
4106         SP = firstlelem - 1;
4107         RETURN;
4108     }
4109
4110     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4111         ix = SvIVx(*lelem);
4112         if (ix < 0)
4113             ix += max;
4114         else
4115             ix -= arybase;
4116         if (ix < 0 || ix >= max)
4117             *lelem = &PL_sv_undef;
4118         else {
4119             is_something_there = TRUE;
4120             if (!(*lelem = firstrelem[ix]))
4121                 *lelem = &PL_sv_undef;
4122         }
4123     }
4124     if (is_something_there)
4125         SP = lastlelem;
4126     else
4127         SP = firstlelem - 1;
4128     RETURN;
4129 }
4130
4131 PP(pp_anonlist)
4132 {
4133     dSP; dMARK; dORIGMARK;
4134     I32 items = SP - MARK;
4135     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4136     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4137     XPUSHs(av);
4138     RETURN;
4139 }
4140
4141 PP(pp_anonhash)
4142 {
4143     dSP; dMARK; dORIGMARK;
4144     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4145
4146     while (MARK < SP) {
4147         SV* key = *++MARK;
4148         SV *val = NEWSV(46, 0);
4149         if (MARK < SP)
4150             sv_setsv(val, *++MARK);
4151         else if (ckWARN(WARN_MISC))
4152             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4153         (void)hv_store_ent(hv,key,val,0);
4154     }
4155     SP = ORIGMARK;
4156     XPUSHs((SV*)hv);
4157     RETURN;
4158 }
4159
4160 PP(pp_splice)
4161 {
4162     dVAR; dSP; dMARK; dORIGMARK;
4163     register AV *ary = (AV*)*++MARK;
4164     register SV **src;
4165     register SV **dst;
4166     register I32 i;
4167     register I32 offset;
4168     register I32 length;
4169     I32 newlen;
4170     I32 after;
4171     I32 diff;
4172     SV **tmparyval = 0;
4173     MAGIC *mg;
4174
4175     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4176         *MARK-- = SvTIED_obj((SV*)ary, mg);
4177         PUSHMARK(MARK);
4178         PUTBACK;
4179         ENTER;
4180         call_method("SPLICE",GIMME_V);
4181         LEAVE;
4182         SPAGAIN;
4183         RETURN;
4184     }
4185
4186     SP++;
4187
4188     if (++MARK < SP) {
4189         offset = i = SvIVx(*MARK);
4190         if (offset < 0)
4191             offset += AvFILLp(ary) + 1;
4192         else
4193             offset -= PL_curcop->cop_arybase;
4194         if (offset < 0)
4195             DIE(aTHX_ PL_no_aelem, i);
4196         if (++MARK < SP) {
4197             length = SvIVx(*MARK++);
4198             if (length < 0) {
4199                 length += AvFILLp(ary) - offset + 1;
4200                 if (length < 0)
4201                     length = 0;
4202             }
4203         }
4204         else
4205             length = AvMAX(ary) + 1;            /* close enough to infinity */
4206     }
4207     else {
4208         offset = 0;
4209         length = AvMAX(ary) + 1;
4210     }
4211     if (offset > AvFILLp(ary) + 1) {
4212         if (ckWARN(WARN_MISC))
4213             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4214         offset = AvFILLp(ary) + 1;
4215     }
4216     after = AvFILLp(ary) + 1 - (offset + length);
4217     if (after < 0) {                            /* not that much array */
4218         length += after;                        /* offset+length now in array */
4219         after = 0;
4220         if (!AvALLOC(ary))
4221             av_extend(ary, 0);
4222     }
4223
4224     /* At this point, MARK .. SP-1 is our new LIST */
4225
4226     newlen = SP - MARK;
4227     diff = newlen - length;
4228     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4229         av_reify(ary);
4230
4231     /* make new elements SVs now: avoid problems if they're from the array */
4232     for (dst = MARK, i = newlen; i; i--) {
4233         SV *h = *dst;
4234         *dst++ = newSVsv(h);
4235     }
4236
4237     if (diff < 0) {                             /* shrinking the area */
4238         if (newlen) {
4239             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4240             Copy(MARK, tmparyval, newlen, SV*);
4241         }
4242
4243         MARK = ORIGMARK + 1;
4244         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4245             MEXTEND(MARK, length);
4246             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4247             if (AvREAL(ary)) {
4248                 EXTEND_MORTAL(length);
4249                 for (i = length, dst = MARK; i; i--) {
4250                     sv_2mortal(*dst);   /* free them eventualy */
4251                     dst++;
4252                 }
4253             }
4254             MARK += length - 1;
4255         }
4256         else {
4257             *MARK = AvARRAY(ary)[offset+length-1];
4258             if (AvREAL(ary)) {
4259                 sv_2mortal(*MARK);
4260                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4261                     SvREFCNT_dec(*dst++);       /* free them now */
4262             }
4263         }
4264         AvFILLp(ary) += diff;
4265
4266         /* pull up or down? */
4267
4268         if (offset < after) {                   /* easier to pull up */
4269             if (offset) {                       /* esp. if nothing to pull */
4270                 src = &AvARRAY(ary)[offset-1];
4271                 dst = src - diff;               /* diff is negative */
4272                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4273                     *dst-- = *src--;
4274             }
4275             dst = AvARRAY(ary);
4276             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4277             AvMAX(ary) += diff;
4278         }
4279         else {
4280             if (after) {                        /* anything to pull down? */
4281                 src = AvARRAY(ary) + offset + length;
4282                 dst = src + diff;               /* diff is negative */
4283                 Move(src, dst, after, SV*);
4284             }
4285             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4286                                                 /* avoid later double free */
4287         }
4288         i = -diff;
4289         while (i)
4290             dst[--i] = &PL_sv_undef;
4291
4292         if (newlen) {
4293             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4294             Safefree(tmparyval);
4295         }
4296     }
4297     else {                                      /* no, expanding (or same) */
4298         if (length) {
4299             New(452, tmparyval, length, SV*);   /* so remember deletion */
4300             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4301         }
4302
4303         if (diff > 0) {                         /* expanding */
4304
4305             /* push up or down? */
4306
4307             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4308                 if (offset) {
4309                     src = AvARRAY(ary);
4310                     dst = src - diff;
4311                     Move(src, dst, offset, SV*);
4312                 }
4313                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4314                 AvMAX(ary) += diff;
4315                 AvFILLp(ary) += diff;
4316             }
4317             else {
4318                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4319                     av_extend(ary, AvFILLp(ary) + diff);
4320                 AvFILLp(ary) += diff;
4321
4322                 if (after) {
4323                     dst = AvARRAY(ary) + AvFILLp(ary);
4324                     src = dst - diff;
4325                     for (i = after; i; i--) {
4326                         *dst-- = *src--;
4327                     }
4328                 }
4329             }
4330         }
4331
4332         if (newlen) {
4333             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4334         }
4335
4336         MARK = ORIGMARK + 1;
4337         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4338             if (length) {
4339                 Copy(tmparyval, MARK, length, SV*);
4340                 if (AvREAL(ary)) {
4341                     EXTEND_MORTAL(length);
4342                     for (i = length, dst = MARK; i; i--) {
4343                         sv_2mortal(*dst);       /* free them eventualy */
4344                         dst++;
4345                     }
4346                 }
4347                 Safefree(tmparyval);
4348             }
4349             MARK += length - 1;
4350         }
4351         else if (length--) {
4352             *MARK = tmparyval[length];
4353             if (AvREAL(ary)) {
4354                 sv_2mortal(*MARK);
4355                 while (length-- > 0)
4356                     SvREFCNT_dec(tmparyval[length]);
4357             }
4358             Safefree(tmparyval);
4359         }
4360         else
4361             *MARK = &PL_sv_undef;
4362     }
4363     SP = MARK;
4364     RETURN;
4365 }
4366
4367 PP(pp_push)
4368 {
4369     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4370     register AV *ary = (AV*)*++MARK;
4371     register SV *sv = &PL_sv_undef;
4372     MAGIC *mg;
4373
4374     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4375         *MARK-- = SvTIED_obj((SV*)ary, mg);
4376         PUSHMARK(MARK);
4377         PUTBACK;
4378         ENTER;
4379         call_method("PUSH",G_SCALAR|G_DISCARD);
4380         LEAVE;
4381         SPAGAIN;
4382     }
4383     else {
4384         /* Why no pre-extend of ary here ? */
4385         for (++MARK; MARK <= SP; MARK++) {
4386             sv = NEWSV(51, 0);
4387             if (*MARK)
4388                 sv_setsv(sv, *MARK);
4389             av_push(ary, sv);
4390         }
4391     }
4392     SP = ORIGMARK;
4393     PUSHi( AvFILL(ary) + 1 );
4394     RETURN;
4395 }
4396
4397 PP(pp_pop)
4398 {
4399     dSP;
4400     AV *av = (AV*)POPs;
4401     SV *sv = av_pop(av);
4402     if (AvREAL(av))
4403         (void)sv_2mortal(sv);
4404     PUSHs(sv);
4405     RETURN;
4406 }
4407
4408 PP(pp_shift)
4409 {
4410     dSP;
4411     AV *av = (AV*)POPs;
4412     SV *sv = av_shift(av);
4413     EXTEND(SP, 1);
4414     if (!sv)
4415         RETPUSHUNDEF;
4416     if (AvREAL(av))
4417         (void)sv_2mortal(sv);
4418     PUSHs(sv);
4419     RETURN;
4420 }
4421
4422 PP(pp_unshift)
4423 {
4424     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4425     register AV *ary = (AV*)*++MARK;
4426     register SV *sv;
4427     register I32 i = 0;
4428     MAGIC *mg;
4429
4430     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4431         *MARK-- = SvTIED_obj((SV*)ary, mg);
4432         PUSHMARK(MARK);
4433         PUTBACK;
4434         ENTER;
4435         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4436         LEAVE;
4437         SPAGAIN;
4438     }
4439     else {
4440         av_unshift(ary, SP - MARK);
4441         while (MARK < SP) {
4442             sv = newSVsv(*++MARK);
4443             (void)av_store(ary, i++, sv);
4444         }
4445     }
4446     SP = ORIGMARK;
4447     PUSHi( AvFILL(ary) + 1 );
4448     RETURN;
4449 }
4450
4451 PP(pp_reverse)
4452 {
4453     dSP; dMARK;
4454     register SV *tmp;
4455     SV **oldsp = SP;
4456
4457     if (GIMME == G_ARRAY) {
4458         MARK++;
4459         while (MARK < SP) {
4460             tmp = *MARK;
4461             *MARK++ = *SP;
4462             *SP-- = tmp;
4463         }
4464         /* safe as long as stack cannot get extended in the above */
4465         SP = oldsp;
4466     }
4467     else {
4468         register char *up;
4469         register char *down;
4470         register I32 tmp;
4471         dTARGET;
4472         STRLEN len;
4473         I32 padoff_du;
4474
4475         SvUTF8_off(TARG);                               /* decontaminate */
4476         if (SP - MARK > 1)
4477             do_join(TARG, &PL_sv_no, MARK, SP);
4478         else
4479             sv_setsv(TARG, (SP > MARK)
4480                     ? *SP
4481                     : (padoff_du = find_rundefsvoffset(),
4482                         (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4483                         ? DEFSV : PAD_SVl(padoff_du)));
4484         up = SvPV_force(TARG, len);
4485         if (len > 1) {
4486             if (DO_UTF8(TARG)) {        /* first reverse each character */
4487                 U8* s = (U8*)SvPVX(TARG);
4488                 const U8* send = (U8*)(s + len);
4489                 while (s < send) {
4490                     if (UTF8_IS_INVARIANT(*s)) {
4491                         s++;
4492                         continue;
4493                     }
4494                     else {
4495                         if (!utf8_to_uvchr(s, 0))
4496                             break;
4497                         up = (char*)s;
4498                         s += UTF8SKIP(s);
4499                         down = (char*)(s - 1);
4500                         /* reverse this character */
4501                         while (down > up) {
4502                             tmp = *up;
4503                             *up++ = *down;
4504                             *down-- = (char)tmp;
4505                         }
4506                     }
4507                 }
4508                 up = SvPVX(TARG);
4509             }
4510             down = SvPVX(TARG) + len - 1;
4511             while (down > up) {
4512                 tmp = *up;
4513                 *up++ = *down;
4514                 *down-- = (char)tmp;
4515             }
4516             (void)SvPOK_only_UTF8(TARG);
4517         }
4518         SP = MARK + 1;
4519         SETTARG;
4520     }
4521     RETURN;
4522 }
4523
4524 PP(pp_split)
4525 {
4526     dVAR; dSP; dTARG;
4527     AV *ary;
4528     register IV limit = POPi;                   /* note, negative is forever */
4529     SV *sv = POPs;
4530     STRLEN len;
4531     register const char *s = SvPV_const(sv, len);
4532     bool do_utf8 = DO_UTF8(sv);
4533     const char *strend = s + len;
4534     register PMOP *pm;
4535     register REGEXP *rx;
4536     register SV *dstr;
4537     register const char *m;
4538     I32 iters = 0;
4539     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4540     I32 maxiters = slen + 10;
4541     I32 i;
4542     const char *orig;
4543     I32 origlimit = limit;
4544     I32 realarray = 0;
4545     I32 base;
4546     const I32 gimme = GIMME_V;
4547     const I32 oldsave = PL_savestack_ix;
4548     I32 make_mortal = 1;
4549     bool multiline = 0;
4550     MAGIC *mg = (MAGIC *) NULL;
4551
4552 #ifdef DEBUGGING
4553     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4554 #else
4555     pm = (PMOP*)POPs;
4556 #endif
4557     if (!pm || !s)
4558         DIE(aTHX_ "panic: pp_split");
4559     rx = PM_GETRE(pm);
4560
4561     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4562              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4563
4564     RX_MATCH_UTF8_set(rx, do_utf8);
4565
4566     if (pm->op_pmreplroot) {
4567 #ifdef USE_ITHREADS
4568         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4569 #else
4570         ary = GvAVn((GV*)pm->op_pmreplroot);
4571 #endif
4572     }
4573     else if (gimme != G_ARRAY)
4574         ary = GvAVn(PL_defgv);
4575     else
4576         ary = Nullav;
4577     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4578         realarray = 1;
4579         PUTBACK;
4580         av_extend(ary,0);
4581         av_clear(ary);
4582         SPAGAIN;
4583         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4584             PUSHMARK(SP);
4585             XPUSHs(SvTIED_obj((SV*)ary, mg));
4586         }
4587         else {
4588             if (!AvREAL(ary)) {
4589                 AvREAL_on(ary);
4590                 AvREIFY_off(ary);
4591                 for (i = AvFILLp(ary); i >= 0; i--)
4592                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4593             }
4594             /* temporarily switch stacks */
4595             SAVESWITCHSTACK(PL_curstack, ary);
4596             make_mortal = 0;
4597         }
4598     }
4599     base = SP - PL_stack_base;
4600     orig = s;
4601     if (pm->op_pmflags & PMf_SKIPWHITE) {
4602         if (pm->op_pmflags & PMf_LOCALE) {
4603             while (isSPACE_LC(*s))
4604                 s++;
4605         }
4606         else {
4607             while (isSPACE(*s))
4608                 s++;
4609         }
4610     }
4611     if (pm->op_pmflags & PMf_MULTILINE) {
4612         multiline = 1;
4613     }
4614
4615     if (!limit)
4616         limit = maxiters + 2;
4617     if (pm->op_pmflags & PMf_WHITE) {
4618         while (--limit) {
4619             m = s;
4620             while (m < strend &&
4621                    !((pm->op_pmflags & PMf_LOCALE)
4622                      ? isSPACE_LC(*m) : isSPACE(*m)))
4623                 ++m;
4624             if (m >= strend)
4625                 break;
4626
4627             dstr = newSVpvn(s, m-s);
4628             if (make_mortal)
4629                 sv_2mortal(dstr);
4630             if (do_utf8)
4631                 (void)SvUTF8_on(dstr);
4632             XPUSHs(dstr);
4633
4634             s = m + 1;
4635             while (s < strend &&
4636                    ((pm->op_pmflags & PMf_LOCALE)
4637                     ? isSPACE_LC(*s) : isSPACE(*s)))
4638                 ++s;
4639         }
4640     }
4641     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4642         while (--limit) {
4643             for (m = s; m < strend && *m != '\n'; m++)
4644                 ;
4645             m++;
4646             if (m >= strend)
4647                 break;
4648             dstr = newSVpvn(s, m-s);
4649             if (make_mortal)
4650                 sv_2mortal(dstr);
4651             if (do_utf8)
4652                 (void)SvUTF8_on(dstr);
4653             XPUSHs(dstr);
4654             s = m;
4655         }
4656     }
4657     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4658              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4659              && (rx->reganch & ROPT_CHECK_ALL)
4660              && !(rx->reganch & ROPT_ANCH)) {
4661         int tail = (rx->reganch & RE_INTUIT_TAIL);
4662         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4663
4664         len = rx->minlen;
4665         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4666             char c = *SvPV_nolen_const(csv);
4667             while (--limit) {
4668                 for (m = s; m < strend && *m != c; m++)
4669                     ;
4670                 if (m >= strend)
4671                     break;
4672                 dstr = newSVpvn(s, m-s);
4673                 if (make_mortal)
4674                     sv_2mortal(dstr);
4675                 if (do_utf8)
4676                     (void)SvUTF8_on(dstr);
4677                 XPUSHs(dstr);
4678                 /* The rx->minlen is in characters but we want to step
4679                  * s ahead by bytes. */
4680                 if (do_utf8)
4681                     s = (char*)utf8_hop((U8*)m, len);
4682                 else
4683                     s = m + len; /* Fake \n at the end */
4684             }
4685         }
4686         else {
4687             while (s < strend && --limit &&
4688               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4689                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4690             {
4691                 dstr = newSVpvn(s, m-s);
4692                 if (make_mortal)
4693                     sv_2mortal(dstr);
4694                 if (do_utf8)
4695                     (void)SvUTF8_on(dstr);
4696                 XPUSHs(dstr);
4697                 /* The rx->minlen is in characters but we want to step
4698                  * s ahead by bytes. */
4699                 if (do_utf8)
4700                     s = (char*)utf8_hop((U8*)m, len);
4701                 else
4702                     s = m + len; /* Fake \n at the end */
4703             }
4704         }
4705     }
4706     else {
4707         maxiters += slen * rx->nparens;
4708         while (s < strend && --limit)
4709         {
4710             PUTBACK;
4711             i = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4712                             sv, NULL, 0);
4713             SPAGAIN;
4714             if (i == 0)
4715                 break;
4716             TAINT_IF(RX_MATCH_TAINTED(rx));
4717             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4718                 m = s;
4719                 s = orig;
4720                 orig = rx->subbeg;
4721                 s = orig + (m - s);
4722                 strend = s + (strend - m);
4723             }
4724             m = rx->startp[0] + orig;
4725             dstr = newSVpvn(s, m-s);
4726             if (make_mortal)
4727                 sv_2mortal(dstr);
4728             if (do_utf8)
4729                 (void)SvUTF8_on(dstr);
4730             XPUSHs(dstr);
4731             if (rx->nparens) {
4732                 for (i = 1; i <= (I32)rx->nparens; i++) {
4733                     s = rx->startp[i] + orig;
4734                     m = rx->endp[i] + orig;
4735
4736                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4737                        parens that didn't match -- they should be set to
4738                        undef, not the empty string */
4739                     if (m >= orig && s >= orig) {
4740                         dstr = newSVpvn(s, m-s);
4741                     }
4742                     else
4743                         dstr = &PL_sv_undef;  /* undef, not "" */
4744                     if (make_mortal)
4745                         sv_2mortal(dstr);
4746                     if (do_utf8)
4747                         (void)SvUTF8_on(dstr);
4748                     XPUSHs(dstr);
4749                 }
4750             }
4751             s = rx->endp[0] + orig;
4752         }
4753     }
4754
4755     iters = (SP - PL_stack_base) - base;
4756     if (iters > maxiters)
4757         DIE(aTHX_ "Split loop");
4758
4759     /* keep field after final delim? */
4760     if (s < strend || (iters && origlimit)) {
4761         STRLEN l = strend - s;
4762         dstr = newSVpvn(s, l);
4763         if (make_mortal)
4764             sv_2mortal(dstr);
4765         if (do_utf8)
4766             (void)SvUTF8_on(dstr);
4767         XPUSHs(dstr);
4768         iters++;
4769     }
4770     else if (!origlimit) {
4771         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4772             if (TOPs && !make_mortal)
4773                 sv_2mortal(TOPs);
4774             iters--;
4775             *SP-- = &PL_sv_undef;
4776         }
4777     }
4778
4779     PUTBACK;
4780     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4781     SPAGAIN;
4782     if (realarray) {
4783         if (!mg) {
4784             if (SvSMAGICAL(ary)) {
4785                 PUTBACK;
4786                 mg_set((SV*)ary);
4787                 SPAGAIN;
4788             }
4789             if (gimme == G_ARRAY) {
4790                 EXTEND(SP, iters);
4791                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4792                 SP += iters;
4793                 RETURN;
4794             }
4795         }
4796         else {
4797             PUTBACK;
4798             ENTER;
4799             call_method("PUSH",G_SCALAR|G_DISCARD);
4800             LEAVE;
4801             SPAGAIN;
4802             if (gimme == G_ARRAY) {
4803                 /* EXTEND should not be needed - we just popped them */
4804                 EXTEND(SP, iters);
4805                 for (i=0; i < iters; i++) {
4806                     SV **svp = av_fetch(ary, i, FALSE);
4807                     PUSHs((svp) ? *svp : &PL_sv_undef);
4808                 }
4809                 RETURN;
4810             }
4811         }
4812     }
4813     else {
4814         if (gimme == G_ARRAY)
4815             RETURN;
4816     }
4817
4818     GETTARGET;
4819     PUSHi(iters);
4820     RETURN;
4821 }
4822
4823 PP(pp_lock)
4824 {
4825     dSP;
4826     dTOPss;
4827     SV *retsv = sv;
4828     SvLOCK(sv);
4829     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4830         || SvTYPE(retsv) == SVt_PVCV) {
4831         retsv = refto(retsv);
4832     }
4833     SETs(retsv);
4834     RETURN;
4835 }
4836
4837 PP(pp_threadsv)
4838 {
4839     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4840 }
4841
4842 /*
4843  * Local variables:
4844  * c-indentation-style: bsd
4845  * c-basic-offset: 4
4846  * indent-tabs-mode: t
4847  * End:
4848  *
4849  * ex: set ts=8 sts=4 sw=4 noet:
4850  */