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