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