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