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