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