pp.c

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