pp.c

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