pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "It's a big house this, and very peculiar.  Always a bit more to discover,
  13  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  14  */
  15
  16 /* This file contains general pp ("push/pop") functions that execute the
  17  * opcodes that make up a perl program. A typical pp function expects to
  18  * find its arguments on the stack, and usually pushes its results onto
  19  * the stack, hence the 'pp' terminology. Each OP structure contains
  20  * a pointer to the relevant pp_foo() function.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_PP_C
  25 #include "perl.h"
  26 #include "keywords.h"
  27
  28 #include "reentr.h"
  29
  30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  31    it, since pid_t is an integral type.
  32    --AD  2/20/1998
  33 */
  34 #ifdef NEED_GETPID_PROTO
  35 extern Pid_t getpid (void);
  36 #endif
  37
  38 /*
  39  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  40  * This switches them over to IEEE.
  41  */
  42 #if defined(LIBM_LIB_VERSION)
  43     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  44 #endif
  45
  46 /* variations on pp_null */
  47
  48 PP(pp_stub)
  49 {
  50     dSP;
  51     if (GIMME_V == G_SCALAR)
  52         XPUSHs(&PL_sv_undef);
  53     RETURN;
  54 }
  55
  56 /* Pushy stuff. */
  57
  58 PP(pp_padav)
  59 {
  60     dSP; dTARGET;
  61     I32 gimme;
  62     if (PL_op->op_private & OPpLVAL_INTRO)
  63         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  64     EXTEND(SP, 1);
  65     if (PL_op->op_flags & OPf_REF) {
  66         PUSHs(TARG);
  67         RETURN;
  68     } else if (LVRET) {
  69         if (GIMME == G_SCALAR)
  70             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  71         PUSHs(TARG);
  72         RETURN;
  73     }
  74     gimme = GIMME_V;
  75     if (gimme == G_ARRAY) {
  76         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  77         EXTEND(SP, maxarg);
  78         if (SvMAGICAL(TARG)) {
  79             U32 i;
  80             for (i=0; i < (U32)maxarg; i++) {
  81                 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
  82                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  83             }
  84         }
  85         else {
  86             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
  87         }
  88         SP += maxarg;
  89     }
  90     else if (gimme == G_SCALAR) {
  91         SV* const sv = sv_newmortal();
  92         const I32 maxarg = AvFILL((AV*)TARG) + 1;
  93         sv_setiv(sv, maxarg);
  94         PUSHs(sv);
  95     }
  96     RETURN;
  97 }
  98
  99 PP(pp_padhv)
 100 {
 101     dSP; dTARGET;
 102     I32 gimme;
 103
 104     XPUSHs(TARG);
 105     if (PL_op->op_private & OPpLVAL_INTRO)
 106         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 107     if (PL_op->op_flags & OPf_REF)
 108         RETURN;
 109     else if (LVRET) {
 110         if (GIMME == G_SCALAR)
 111             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 112         RETURN;
 113     }
 114     gimme = GIMME_V;
 115     if (gimme == G_ARRAY) {
 116         RETURNOP(do_kv());
 117     }
 118     else if (gimme == G_SCALAR) {
 119         SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
 120         SETs(sv);
 121     }
 122     RETURN;
 123 }
 124
 125 /* Translations. */
 126
 127 PP(pp_rv2gv)
 128 {
 129     dSP; dTOPss;
 130
 131     if (SvROK(sv)) {
 132       wasref:
 133         tryAMAGICunDEREF(to_gv);
 134
 135         sv = SvRV(sv);
 136         if (SvTYPE(sv) == SVt_PVIO) {
 137             GV * const gv = (GV*) sv_newmortal();
 138             gv_init(gv, 0, "", 0, 0);
 139             GvIOp(gv) = (IO *)sv;
 140             (void)SvREFCNT_inc(sv);
 141             sv = (SV*) gv;
 142         }
 143         else if (SvTYPE(sv) != SVt_PVGV)
 144             DIE(aTHX_ "Not a GLOB reference");
 145     }
 146     else {
 147         if (SvTYPE(sv) != SVt_PVGV) {
 148             if (SvGMAGICAL(sv)) {
 149                 mg_get(sv);
 150                 if (SvROK(sv))
 151                     goto wasref;
 152             }
 153             if (!SvOK(sv) && sv != &PL_sv_undef) {
 154                 /* If this is a 'my' scalar and flag is set then vivify
 155                  * NI-S 1999/05/07
 156                  */
 157                 if (SvREADONLY(sv))
 158                     Perl_croak(aTHX_ PL_no_modify);
 159                 if (PL_op->op_private & OPpDEREF) {
 160                     GV *gv;
 161                     if (cUNOP->op_targ) {
 162                         STRLEN len;
 163                         SV *namesv = PAD_SV(cUNOP->op_targ);
 164                         const char *name = SvPV(namesv, len);
 165                         gv = (GV*)NEWSV(0,0);
 166                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 167                     }
 168                     else {
 169                         const char *name = CopSTASHPV(PL_curcop);
 170                         gv = newGVgen(name);
 171                     }
 172                     if (SvTYPE(sv) < SVt_RV)
 173                         sv_upgrade(sv, SVt_RV);
 174                     if (SvPVX_const(sv)) {
 175                         SvPV_free(sv);
 176                         SvLEN_set(sv, 0);
 177                         SvCUR_set(sv, 0);
 178                     }
 179                     SvRV_set(sv, (SV*)gv);
 180                     SvROK_on(sv);
 181                     SvSETMAGIC(sv);
 182                     goto wasref;
 183                 }
 184                 if (PL_op->op_flags & OPf_REF ||
 185                     PL_op->op_private & HINT_STRICT_REFS)
 186                     DIE(aTHX_ PL_no_usym, "a symbol");
 187                 if (ckWARN(WARN_UNINITIALIZED))
 188                     report_uninit(sv);
 189                 RETSETUNDEF;
 190             }
 191             if ((PL_op->op_flags & OPf_SPECIAL) &&
 192                 !(PL_op->op_flags & OPf_MOD))
 193             {
 194                 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
 195                 if (!temp
 196                     && (!is_gv_magical_sv(sv,0)
 197                         || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
 198                     RETSETUNDEF;
 199                 }
 200                 sv = temp;
 201             }
 202             else {
 203                 if (PL_op->op_private & HINT_STRICT_REFS)
 204                     DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
 205                 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
 206             }
 207         }
 208     }
 209     if (PL_op->op_private & OPpLVAL_INTRO)
 210         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 211     SETs(sv);
 212     RETURN;
 213 }
 214
 215 PP(pp_rv2sv)
 216 {
 217     GV *gv = Nullgv;
 218     dSP; dTOPss;
 219
 220     if (SvROK(sv)) {
 221       wasref:
 222         tryAMAGICunDEREF(to_sv);
 223
 224         sv = SvRV(sv);
 225         switch (SvTYPE(sv)) {
 226         case SVt_PVAV:
 227         case SVt_PVHV:
 228         case SVt_PVCV:
 229             DIE(aTHX_ "Not a SCALAR reference");
 230         }
 231     }
 232     else {
 233         gv = (GV*)sv;
 234
 235         if (SvTYPE(gv) != SVt_PVGV) {
 236             if (SvGMAGICAL(sv)) {
 237                 mg_get(sv);
 238                 if (SvROK(sv))
 239                     goto wasref;
 240             }
 241             if (!SvOK(sv)) {
 242                 if (PL_op->op_flags & OPf_REF ||
 243                     PL_op->op_private & HINT_STRICT_REFS)
 244                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 245                 if (ckWARN(WARN_UNINITIALIZED))
 246                     report_uninit(sv);
 247                 RETSETUNDEF;
 248             }
 249             if ((PL_op->op_flags & OPf_SPECIAL) &&
 250                 !(PL_op->op_flags & OPf_MOD))
 251             {
 252                 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
 253                 if (!gv
 254                     && (!is_gv_magical_sv(sv, 0)
 255                         || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
 256                 {
 257                     RETSETUNDEF;
 258                 }
 259             }
 260             else {
 261                 if (PL_op->op_private & HINT_STRICT_REFS)
 262                     DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
 263                 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
 264             }
 265         }
 266         sv = GvSVn(gv);
 267     }
 268     if (PL_op->op_flags & OPf_MOD) {
 269         if (PL_op->op_private & OPpLVAL_INTRO) {
 270             if (cUNOP->op_first->op_type == OP_NULL)
 271                 sv = save_scalar((GV*)TOPs);
 272             else if (gv)
 273                 sv = save_scalar(gv);
 274             else
 275                 Perl_croak(aTHX_ PL_no_localize_ref);
 276         }
 277         else if (PL_op->op_private & OPpDEREF)
 278             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 279     }
 280     SETs(sv);
 281     RETURN;
 282 }
 283
 284 PP(pp_av2arylen)
 285 {
 286     dSP;
 287     AV * const av = (AV*)TOPs;
 288     SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
 289     if (!*sv) {
 290         *sv = NEWSV(0,0);
 291         sv_upgrade(*sv, SVt_PVMG);
 292         sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
 293     }
 294     SETs(*sv);
 295     RETURN;
 296 }
 297
 298 PP(pp_pos)
 299 {
 300     dSP; dTARGET; dPOPss;
 301
 302     if (PL_op->op_flags & OPf_MOD || LVRET) {
 303         if (SvTYPE(TARG) < SVt_PVLV) {
 304             sv_upgrade(TARG, SVt_PVLV);
 305             sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
 306         }
 307
 308         LvTYPE(TARG) = '.';
 309         if (LvTARG(TARG) != sv) {
 310             if (LvTARG(TARG))
 311                 SvREFCNT_dec(LvTARG(TARG));
 312             LvTARG(TARG) = SvREFCNT_inc(sv);
 313         }
 314         PUSHs(TARG);    /* no SvSETMAGIC */
 315         RETURN;
 316     }
 317     else {
 318         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 319             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 320             if (mg && mg->mg_len >= 0) {
 321                 I32 i = mg->mg_len;
 322                 if (DO_UTF8(sv))
 323                     sv_pos_b2u(sv, &i);
 324                 PUSHi(i + PL_curcop->cop_arybase);
 325                 RETURN;
 326             }
 327         }
 328         RETPUSHUNDEF;
 329     }
 330 }
 331
 332 PP(pp_rv2cv)
 333 {
 334     dSP;
 335     GV *gv;
 336     HV *stash;
 337
 338     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 339     /* (But not in defined().) */
 340     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
 341     if (cv) {
 342         if (CvCLONE(cv))
 343             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 344         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 345             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 346                 cv = GvCV(gv);
 347             if (!CvLVALUE(cv))
 348                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 349         }
 350     }
 351     else
 352         cv = (CV*)&PL_sv_undef;
 353     SETs((SV*)cv);
 354     RETURN;
 355 }
 356
 357 PP(pp_prototype)
 358 {
 359     dSP;
 360     CV *cv;
 361     HV *stash;
 362     GV *gv;
 363     SV *ret;
 364
 365     ret = &PL_sv_undef;
 366     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 367         const char *s = SvPVX_const(TOPs);
 368         if (strnEQ(s, "CORE::", 6)) {
 369             const int code = keyword(s + 6, SvCUR(TOPs) - 6);
 370             if (code < 0) {     /* Overridable. */
 371 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 372                 int i = 0, n = 0, seen_question = 0;
 373                 I32 oa;
 374                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 375
 376                 if (code == -KEY_chop || code == -KEY_chomp
 377                         || code == -KEY_exec || code == -KEY_system)
 378                     goto set;
 379                 while (i < MAXO) {      /* The slow way. */
 380                     if (strEQ(s + 6, PL_op_name[i])
 381                         || strEQ(s + 6, PL_op_desc[i]))
 382                     {
 383                         goto found;
 384                     }
 385                     i++;
 386                 }
 387                 goto nonesuch;          /* Should not happen... */
 388               found:
 389                 oa = PL_opargs[i] >> OASHIFT;
 390                 while (oa) {
 391                     if (oa & OA_OPTIONAL && !seen_question) {
 392                         seen_question = 1;
 393                         str[n++] = ';';
 394                     }
 395                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 396                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 397                         /* But globs are already references (kinda) */
 398                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 399                     ) {
 400                         str[n++] = '\\';
 401                     }
 402                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 403                     oa = oa >> 4;
 404                 }
 405                 str[n++] = '\0';
 406                 ret = sv_2mortal(newSVpvn(str, n - 1));
 407             }
 408             else if (code)              /* Non-Overridable */
 409                 goto set;
 410             else {                      /* None such */
 411               nonesuch:
 412                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 413             }
 414         }
 415     }
 416     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 417     if (cv && SvPOK(cv))
 418         ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
 419   set:
 420     SETs(ret);
 421     RETURN;
 422 }
 423
 424 PP(pp_anoncode)
 425 {
 426     dSP;
 427     CV* cv = (CV*)PAD_SV(PL_op->op_targ);
 428     if (CvCLONE(cv))
 429         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 430     EXTEND(SP,1);
 431     PUSHs((SV*)cv);
 432     RETURN;
 433 }
 434
 435 PP(pp_srefgen)
 436 {
 437     dSP;
 438     *SP = refto(*SP);
 439     RETURN;
 440 }
 441
 442 PP(pp_refgen)
 443 {
 444     dSP; dMARK;
 445     if (GIMME != G_ARRAY) {
 446         if (++MARK <= SP)
 447             *MARK = *SP;
 448         else
 449             *MARK = &PL_sv_undef;
 450         *MARK = refto(*MARK);
 451         SP = MARK;
 452         RETURN;
 453     }
 454     EXTEND_MORTAL(SP - MARK);
 455     while (++MARK <= SP)
 456         *MARK = refto(*MARK);
 457     RETURN;
 458 }
 459
 460 STATIC SV*
 461 S_refto(pTHX_ SV *sv)
 462 {
 463     SV* rv;
 464
 465     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 466         if (LvTARGLEN(sv))
 467             vivify_defelem(sv);
 468         if (!(sv = LvTARG(sv)))
 469             sv = &PL_sv_undef;
 470         else
 471             (void)SvREFCNT_inc(sv);
 472     }
 473     else if (SvTYPE(sv) == SVt_PVAV) {
 474         if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
 475             av_reify((AV*)sv);
 476         SvTEMP_off(sv);
 477         (void)SvREFCNT_inc(sv);
 478     }
 479     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 480         sv = newSVsv(sv);
 481     else {
 482         SvTEMP_off(sv);
 483         (void)SvREFCNT_inc(sv);
 484     }
 485     rv = sv_newmortal();
 486     sv_upgrade(rv, SVt_RV);
 487     SvRV_set(rv, sv);
 488     SvROK_on(rv);
 489     return rv;
 490 }
 491
 492 PP(pp_ref)
 493 {
 494     dSP; dTARGET;
 495     const char *pv;
 496     SV * const sv = POPs;
 497
 498     if (sv)
 499         SvGETMAGIC(sv);
 500
 501     if (!sv || !SvROK(sv))
 502         RETPUSHNO;
 503
 504     pv = sv_reftype(SvRV(sv),TRUE);
 505     PUSHp(pv, strlen(pv));
 506     RETURN;
 507 }
 508
 509 PP(pp_bless)
 510 {
 511     dSP;
 512     HV *stash;
 513
 514     if (MAXARG == 1)
 515         stash = CopSTASH(PL_curcop);
 516     else {
 517         SV * const ssv = POPs;
 518         STRLEN len;
 519         const char *ptr;
 520
 521         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 522             Perl_croak(aTHX_ "Attempt to bless into a reference");
 523         ptr = SvPV_const(ssv,len);
 524         if (len == 0 && ckWARN(WARN_MISC))
 525             Perl_warner(aTHX_ packWARN(WARN_MISC),
 526                    "Explicit blessing to '' (assuming package main)");
 527         stash = gv_stashpvn(ptr, len, TRUE);
 528     }
 529
 530     (void)sv_bless(TOPs, stash);
 531     RETURN;
 532 }
 533
 534 PP(pp_gelem)
 535 {
 536     dSP;
 537
 538     SV *sv = POPs;
 539     const char * const elem = SvPV_nolen_const(sv);
 540     GV * const gv = (GV*)POPs;
 541     SV * tmpRef = Nullsv;
 542
 543     sv = Nullsv;
 544     if (elem) {
 545         /* elem will always be NUL terminated.  */
 546         const char * const second_letter = elem + 1;
 547         switch (*elem) {
 548         case 'A':
 549             if (strEQ(second_letter, "RRAY"))
 550                 tmpRef = (SV*)GvAV(gv);
 551             break;
 552         case 'C':
 553             if (strEQ(second_letter, "ODE"))
 554                 tmpRef = (SV*)GvCVu(gv);
 555             break;
 556         case 'F':
 557             if (strEQ(second_letter, "ILEHANDLE")) {
 558                 /* finally deprecated in 5.8.0 */
 559                 deprecate("*glob{FILEHANDLE}");
 560                 tmpRef = (SV*)GvIOp(gv);
 561             }
 562             else
 563                 if (strEQ(second_letter, "ORMAT"))
 564                     tmpRef = (SV*)GvFORM(gv);
 565             break;
 566         case 'G':
 567             if (strEQ(second_letter, "LOB"))
 568                 tmpRef = (SV*)gv;
 569             break;
 570         case 'H':
 571             if (strEQ(second_letter, "ASH"))
 572                 tmpRef = (SV*)GvHV(gv);
 573             break;
 574         case 'I':
 575             if (*second_letter == 'O' && !elem[2])
 576                 tmpRef = (SV*)GvIOp(gv);
 577             break;
 578         case 'N':
 579             if (strEQ(second_letter, "AME"))
 580                 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 581             break;
 582         case 'P':
 583             if (strEQ(second_letter, "ACKAGE")) {
 584                 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
 585                 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
 586             }
 587             break;
 588         case 'S':
 589             if (strEQ(second_letter, "CALAR"))
 590                 tmpRef = GvSV(gv);
 591             break;
 592         }
 593     }
 594     if (tmpRef)
 595         sv = newRV(tmpRef);
 596     if (sv)
 597         sv_2mortal(sv);
 598     else
 599         sv = &PL_sv_undef;
 600     XPUSHs(sv);
 601     RETURN;
 602 }
 603
 604 /* Pattern matching */
 605
 606 PP(pp_study)
 607 {
 608     dSP; dPOPss;
 609     register unsigned char *s;
 610     register I32 pos;
 611     register I32 ch;
 612     register I32 *sfirst;
 613     register I32 *snext;
 614     STRLEN len;
 615
 616     if (sv == PL_lastscream) {
 617         if (SvSCREAM(sv))
 618             RETPUSHYES;
 619     }
 620     else {
 621         if (PL_lastscream) {
 622             SvSCREAM_off(PL_lastscream);
 623             SvREFCNT_dec(PL_lastscream);
 624         }
 625         PL_lastscream = SvREFCNT_inc(sv);
 626     }
 627
 628     s = (unsigned char*)(SvPV(sv, len));
 629     pos = len;
 630     if (pos <= 0)
 631         RETPUSHNO;
 632     if (pos > PL_maxscream) {
 633         if (PL_maxscream < 0) {
 634             PL_maxscream = pos + 80;
 635             Newx(PL_screamfirst, 256, I32);
 636             Newx(PL_screamnext, PL_maxscream, I32);
 637         }
 638         else {
 639             PL_maxscream = pos + pos / 4;
 640             Renew(PL_screamnext, PL_maxscream, I32);
 641         }
 642     }
 643
 644     sfirst = PL_screamfirst;
 645     snext = PL_screamnext;
 646
 647     if (!sfirst || !snext)
 648         DIE(aTHX_ "do_study: out of memory");
 649
 650     for (ch = 256; ch; --ch)
 651         *sfirst++ = -1;
 652     sfirst -= 256;
 653
 654     while (--pos >= 0) {
 655         register const I32 ch = s[pos];
 656         if (sfirst[ch] >= 0)
 657             snext[pos] = sfirst[ch] - pos;
 658         else
 659             snext[pos] = -pos;
 660         sfirst[ch] = pos;
 661     }
 662
 663     SvSCREAM_on(sv);
 664     /* piggyback on m//g magic */
 665     sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 666     RETPUSHYES;
 667 }
 668
 669 PP(pp_trans)
 670 {
 671     dSP; dTARG;
 672     SV *sv;
 673
 674     if (PL_op->op_flags & OPf_STACKED)
 675         sv = POPs;
 676     else if (PL_op->op_private & OPpTARGET_MY)
 677         sv = GETTARGET;
 678     else {
 679         sv = DEFSV;
 680         EXTEND(SP,1);
 681     }
 682     TARG = sv_newmortal();
 683     PUSHi(do_trans(sv));
 684     RETURN;
 685 }
 686
 687 /* Lvalue operators. */
 688
 689 PP(pp_schop)
 690 {
 691     dSP; dTARGET;
 692     do_chop(TARG, TOPs);
 693     SETTARG;
 694     RETURN;
 695 }
 696
 697 PP(pp_chop)
 698 {
 699     dSP; dMARK; dTARGET; dORIGMARK;
 700     while (MARK < SP)
 701         do_chop(TARG, *++MARK);
 702     SP = ORIGMARK;
 703     PUSHTARG;
 704     RETURN;
 705 }
 706
 707 PP(pp_schomp)
 708 {
 709     dSP; dTARGET;
 710     SETi(do_chomp(TOPs));
 711     RETURN;
 712 }
 713
 714 PP(pp_chomp)
 715 {
 716     dSP; dMARK; dTARGET;
 717     register I32 count = 0;
 718
 719     while (SP > MARK)
 720         count += do_chomp(POPs);
 721     PUSHi(count);
 722     RETURN;
 723 }
 724
 725 PP(pp_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(slt,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(sgt,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(sle,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(sge,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         utf8_to_uvchr(tmpbuf, 0);
3396
3397         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3398             dTARGET;
3399             /* slen is the byte length of the whole SV.
3400              * ulen is the byte length of the original Unicode character
3401              * stored as UTF-8 at s.
3402              * tculen is the byte length of the freshly titlecased
3403              * Unicode character stored as UTF-8 at tmpbuf.
3404              * We first set the result to be the titlecased character,
3405              * and then append the rest of the SV data. */
3406             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3407             if (slen > ulen)
3408                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3409             SvUTF8_on(TARG);
3410             SETs(TARG);
3411         }
3412         else {
3413             s = (U8*)SvPV_force_nomg(sv, slen);
3414             Copy(tmpbuf, s, tculen, U8);
3415         }
3416     }
3417     else {
3418         U8 *s1;
3419         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3420             dTARGET;
3421             SvUTF8_off(TARG);                           /* decontaminate */
3422             sv_setsv_nomg(TARG, sv);
3423             sv = TARG;
3424             SETs(sv);
3425         }
3426         s1 = (U8*)SvPV_force_nomg(sv, slen);
3427         if (*s1) {
3428             if (IN_LOCALE_RUNTIME) {
3429                 TAINT;
3430                 SvTAINTED_on(sv);
3431                 *s1 = toUPPER_LC(*s1);
3432             }
3433             else
3434                 *s1 = toUPPER(*s1);
3435         }
3436     }
3437     SvSETMAGIC(sv);
3438     RETURN;
3439 }
3440
3441 PP(pp_lcfirst)
3442 {
3443     dSP;
3444     SV *sv = TOPs;
3445     const U8 *s;
3446     STRLEN slen;
3447
3448     SvGETMAGIC(sv);
3449     if (DO_UTF8(sv) &&
3450         (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3451         UTF8_IS_START(*s)) {
3452         STRLEN ulen;
3453         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3454         U8 *tend;
3455         UV uv;
3456
3457         toLOWER_utf8(s, tmpbuf, &ulen);
3458         uv = utf8_to_uvchr(tmpbuf, 0);
3459         tend = uvchr_to_utf8(tmpbuf, uv);
3460
3461         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3462             dTARGET;
3463             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3464             if (slen > ulen)
3465                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3466             SvUTF8_on(TARG);
3467             SETs(TARG);
3468         }
3469         else {
3470             s = (U8*)SvPV_force_nomg(sv, slen);
3471             Copy(tmpbuf, s, ulen, U8);
3472         }
3473     }
3474     else {
3475         U8 *s1;
3476         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3477             dTARGET;
3478             SvUTF8_off(TARG);                           /* decontaminate */
3479             sv_setsv_nomg(TARG, sv);
3480             sv = TARG;
3481             SETs(sv);
3482         }
3483         s1 = (U8*)SvPV_force_nomg(sv, slen);
3484         if (*s1) {
3485             if (IN_LOCALE_RUNTIME) {
3486                 TAINT;
3487                 SvTAINTED_on(sv);
3488                 *s1 = toLOWER_LC(*s1);
3489             }
3490             else
3491                 *s1 = toLOWER(*s1);
3492         }
3493     }
3494     SvSETMAGIC(sv);
3495     RETURN;
3496 }
3497
3498 PP(pp_uc)
3499 {
3500     dSP;
3501     SV *sv = TOPs;
3502     STRLEN len;
3503
3504     SvGETMAGIC(sv);
3505     if (DO_UTF8(sv)) {
3506         dTARGET;
3507         STRLEN ulen;
3508         register U8 *d;
3509         const U8 *s;
3510         const U8 *send;
3511         U8 tmpbuf[UTF8_MAXBYTES+1];
3512
3513         s = (const U8*)SvPV_nomg_const(sv,len);
3514         if (!len) {
3515             SvUTF8_off(TARG);                           /* decontaminate */
3516             sv_setpvn(TARG, "", 0);
3517             SETs(TARG);
3518         }
3519         else {
3520             STRLEN min = len + 1;
3521
3522             SvUPGRADE(TARG, SVt_PV);
3523             SvGROW(TARG, min);
3524             (void)SvPOK_only(TARG);
3525             d = (U8*)SvPVX(TARG);
3526             send = s + len;
3527             while (s < send) {
3528                 STRLEN u = UTF8SKIP(s);
3529
3530                 toUPPER_utf8(s, tmpbuf, &ulen);
3531                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3532                     /* If the eventually required minimum size outgrows
3533                      * the available space, we need to grow. */
3534                     UV o = d - (U8*)SvPVX_const(TARG);
3535
3536                     /* If someone uppercases one million U+03B0s we
3537                      * SvGROW() one million times.  Or we could try
3538                      * guessing how much to allocate without allocating
3539                      * too much. Such is life. */
3540                     SvGROW(TARG, min);
3541                     d = (U8*)SvPVX(TARG) + o;
3542                 }
3543                 Copy(tmpbuf, d, ulen, U8);
3544                 d += ulen;
3545                 s += u;
3546             }
3547             *d = '\0';
3548             SvUTF8_on(TARG);
3549             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3550             SETs(TARG);
3551         }
3552     }
3553     else {
3554         U8 *s;
3555         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3556             dTARGET;
3557             SvUTF8_off(TARG);                           /* decontaminate */
3558             sv_setsv_nomg(TARG, sv);
3559             sv = TARG;
3560             SETs(sv);
3561         }
3562         s = (U8*)SvPV_force_nomg(sv, len);
3563         if (len) {
3564             register const U8 *send = s + len;
3565
3566             if (IN_LOCALE_RUNTIME) {
3567                 TAINT;
3568                 SvTAINTED_on(sv);
3569                 for (; s < send; s++)
3570                     *s = toUPPER_LC(*s);
3571             }
3572             else {
3573                 for (; s < send; s++)
3574                     *s = toUPPER(*s);
3575             }
3576         }
3577     }
3578     SvSETMAGIC(sv);
3579     RETURN;
3580 }
3581
3582 PP(pp_lc)
3583 {
3584     dSP;
3585     SV *sv = TOPs;
3586     STRLEN len;
3587
3588     SvGETMAGIC(sv);
3589     if (DO_UTF8(sv)) {
3590         dTARGET;
3591         const U8 *s;
3592         STRLEN ulen;
3593         register U8 *d;
3594         const U8 *send;
3595         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3596
3597         s = (const U8*)SvPV_nomg_const(sv,len);
3598         if (!len) {
3599             SvUTF8_off(TARG);                           /* decontaminate */
3600             sv_setpvn(TARG, "", 0);
3601             SETs(TARG);
3602         }
3603         else {
3604             STRLEN min = len + 1;
3605
3606             SvUPGRADE(TARG, SVt_PV);
3607             SvGROW(TARG, min);
3608             (void)SvPOK_only(TARG);
3609             d = (U8*)SvPVX(TARG);
3610             send = s + len;
3611             while (s < send) {
3612                 const STRLEN u = UTF8SKIP(s);
3613                 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3614
3615 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3616                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3617                      /*
3618                       * Now if the sigma is NOT followed by
3619                       * /$ignorable_sequence$cased_letter/;
3620                       * and it IS preceded by
3621                       * /$cased_letter$ignorable_sequence/;
3622                       * where $ignorable_sequence is
3623                       * [\x{2010}\x{AD}\p{Mn}]*
3624                       * and $cased_letter is
3625                       * [\p{Ll}\p{Lo}\p{Lt}]
3626                       * then it should be mapped to 0x03C2,
3627                       * (GREEK SMALL LETTER FINAL SIGMA),
3628                       * instead of staying 0x03A3.
3629                       * "should be": in other words,
3630                       * this is not implemented yet.
3631                       * See lib/unicore/SpecialCasing.txt.
3632                       */
3633                 }
3634                 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3635                     /* If the eventually required minimum size outgrows
3636                      * the available space, we need to grow. */
3637                     UV o = d - (U8*)SvPVX_const(TARG);
3638
3639                     /* If someone lowercases one million U+0130s we
3640                      * SvGROW() one million times.  Or we could try
3641                      * guessing how much to allocate without allocating.
3642                      * too much.  Such is life. */
3643                     SvGROW(TARG, min);
3644                     d = (U8*)SvPVX(TARG) + o;
3645                 }
3646                 Copy(tmpbuf, d, ulen, U8);
3647                 d += ulen;
3648                 s += u;
3649             }
3650             *d = '\0';
3651             SvUTF8_on(TARG);
3652             SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3653             SETs(TARG);
3654         }
3655     }
3656     else {
3657         U8 *s;
3658         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3659             dTARGET;
3660             SvUTF8_off(TARG);                           /* decontaminate */
3661             sv_setsv_nomg(TARG, sv);
3662             sv = TARG;
3663             SETs(sv);
3664         }
3665
3666         s = (U8*)SvPV_force_nomg(sv, len);
3667         if (len) {
3668             register const U8 * const send = s + len;
3669
3670             if (IN_LOCALE_RUNTIME) {
3671                 TAINT;
3672                 SvTAINTED_on(sv);
3673                 for (; s < send; s++)
3674                     *s = toLOWER_LC(*s);
3675             }
3676             else {
3677                 for (; s < send; s++)
3678                     *s = toLOWER(*s);
3679             }
3680         }
3681     }
3682     SvSETMAGIC(sv);
3683     RETURN;
3684 }
3685
3686 PP(pp_quotemeta)
3687 {
3688     dSP; dTARGET;
3689     SV * const sv = TOPs;
3690     STRLEN len;
3691     register const char *s = SvPV_const(sv,len);
3692
3693     SvUTF8_off(TARG);                           /* decontaminate */
3694     if (len) {
3695         register char *d;
3696         SvUPGRADE(TARG, SVt_PV);
3697         SvGROW(TARG, (len * 2) + 1);
3698         d = SvPVX(TARG);
3699         if (DO_UTF8(sv)) {
3700             while (len) {
3701                 if (UTF8_IS_CONTINUED(*s)) {
3702                     STRLEN ulen = UTF8SKIP(s);
3703                     if (ulen > len)
3704                         ulen = len;
3705                     len -= ulen;
3706                     while (ulen--)
3707                         *d++ = *s++;
3708                 }
3709                 else {
3710                     if (!isALNUM(*s))
3711                         *d++ = '\\';
3712                     *d++ = *s++;
3713                     len--;
3714                 }
3715             }
3716             SvUTF8_on(TARG);
3717         }
3718         else {
3719             while (len--) {
3720                 if (!isALNUM(*s))
3721                     *d++ = '\\';
3722                 *d++ = *s++;
3723             }
3724         }
3725         *d = '\0';
3726         SvCUR_set(TARG, d - SvPVX_const(TARG));
3727         (void)SvPOK_only_UTF8(TARG);
3728     }
3729     else
3730         sv_setpvn(TARG, s, len);
3731     SETs(TARG);
3732     if (SvSMAGICAL(TARG))
3733         mg_set(TARG);
3734     RETURN;
3735 }
3736
3737 /* Arrays. */
3738
3739 PP(pp_aslice)
3740 {
3741     dSP; dMARK; dORIGMARK;
3742     register AV* const av = (AV*)POPs;
3743     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3744
3745     if (SvTYPE(av) == SVt_PVAV) {
3746         const I32 arybase = PL_curcop->cop_arybase;
3747         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3748             register SV **svp;
3749             I32 max = -1;
3750             for (svp = MARK + 1; svp <= SP; svp++) {
3751                 const I32 elem = SvIVx(*svp);
3752                 if (elem > max)
3753                     max = elem;
3754             }
3755             if (max > AvMAX(av))
3756                 av_extend(av, max);
3757         }
3758         while (++MARK <= SP) {
3759             register SV **svp;
3760             I32 elem = SvIVx(*MARK);
3761
3762             if (elem > 0)
3763                 elem -= arybase;
3764             svp = av_fetch(av, elem, lval);
3765             if (lval) {
3766                 if (!svp || *svp == &PL_sv_undef)
3767                     DIE(aTHX_ PL_no_aelem, elem);
3768                 if (PL_op->op_private & OPpLVAL_INTRO)
3769                     save_aelem(av, elem, svp);
3770             }
3771             *MARK = svp ? *svp : &PL_sv_undef;
3772         }
3773     }
3774     if (GIMME != G_ARRAY) {
3775         MARK = ORIGMARK;
3776         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3777         SP = MARK;
3778     }
3779     RETURN;
3780 }
3781
3782 /* Associative arrays. */
3783
3784 PP(pp_each)
3785 {
3786     dSP;
3787     HV * const hash = (HV*)POPs;
3788     HE *entry;
3789     const I32 gimme = GIMME_V;
3790
3791     PUTBACK;
3792     /* might clobber stack_sp */
3793     entry = hv_iternext(hash);
3794     SPAGAIN;
3795
3796     EXTEND(SP, 2);
3797     if (entry) {
3798         SV* const sv = hv_iterkeysv(entry);
3799         PUSHs(sv);      /* won't clobber stack_sp */
3800         if (gimme == G_ARRAY) {
3801             SV *val;
3802             PUTBACK;
3803             /* might clobber stack_sp */
3804             val = hv_iterval(hash, entry);
3805             SPAGAIN;
3806             PUSHs(val);
3807         }
3808     }
3809     else if (gimme == G_SCALAR)
3810         RETPUSHUNDEF;
3811
3812     RETURN;
3813 }
3814
3815 PP(pp_delete)
3816 {
3817     dSP;
3818     const I32 gimme = GIMME_V;
3819     const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3820
3821     if (PL_op->op_private & OPpSLICE) {
3822         dMARK; dORIGMARK;
3823         HV * const hv = (HV*)POPs;
3824         const U32 hvtype = SvTYPE(hv);
3825         if (hvtype == SVt_PVHV) {                       /* hash element */
3826             while (++MARK <= SP) {
3827                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3828                 *MARK = sv ? sv : &PL_sv_undef;
3829             }
3830         }
3831         else if (hvtype == SVt_PVAV) {                  /* array element */
3832             if (PL_op->op_flags & OPf_SPECIAL) {
3833                 while (++MARK <= SP) {
3834                     SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3835                     *MARK = sv ? sv : &PL_sv_undef;
3836                 }
3837             }
3838         }
3839         else
3840             DIE(aTHX_ "Not a HASH reference");
3841         if (discard)
3842             SP = ORIGMARK;
3843         else if (gimme == G_SCALAR) {
3844             MARK = ORIGMARK;
3845             if (SP > MARK)
3846                 *++MARK = *SP;
3847             else
3848                 *++MARK = &PL_sv_undef;
3849             SP = MARK;
3850         }
3851     }
3852     else {
3853         SV *keysv = POPs;
3854         HV * const hv = (HV*)POPs;
3855         SV *sv;
3856         if (SvTYPE(hv) == SVt_PVHV)
3857             sv = hv_delete_ent(hv, keysv, discard, 0);
3858         else if (SvTYPE(hv) == SVt_PVAV) {
3859             if (PL_op->op_flags & OPf_SPECIAL)
3860                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3861             else
3862                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3863         }
3864         else
3865             DIE(aTHX_ "Not a HASH reference");
3866         if (!sv)
3867             sv = &PL_sv_undef;
3868         if (!discard)
3869             PUSHs(sv);
3870     }
3871     RETURN;
3872 }
3873
3874 PP(pp_exists)
3875 {
3876     dSP;
3877     SV *tmpsv;
3878     HV *hv;
3879
3880     if (PL_op->op_private & OPpEXISTS_SUB) {
3881         GV *gv;
3882         SV *sv = POPs;
3883         CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3884         if (cv)
3885             RETPUSHYES;
3886         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3887             RETPUSHYES;
3888         RETPUSHNO;
3889     }
3890     tmpsv = POPs;
3891     hv = (HV*)POPs;
3892     if (SvTYPE(hv) == SVt_PVHV) {
3893         if (hv_exists_ent(hv, tmpsv, 0))
3894             RETPUSHYES;
3895     }
3896     else if (SvTYPE(hv) == SVt_PVAV) {
3897         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3898             if (av_exists((AV*)hv, SvIV(tmpsv)))
3899                 RETPUSHYES;
3900         }
3901     }
3902     else {
3903         DIE(aTHX_ "Not a HASH reference");
3904     }
3905     RETPUSHNO;
3906 }
3907
3908 PP(pp_hslice)
3909 {
3910     dSP; dMARK; dORIGMARK;
3911     register HV * const hv = (HV*)POPs;
3912     register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3913     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3914     bool other_magic = FALSE;
3915
3916     if (localizing) {
3917         MAGIC *mg;
3918         HV *stash;
3919
3920         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3921             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3922              /* Try to preserve the existenceness of a tied hash
3923               * element by using EXISTS and DELETE if possible.
3924               * Fallback to FETCH and STORE otherwise */
3925              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3926              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3927              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3928     }
3929
3930     while (++MARK <= SP) {
3931         SV * const keysv = *MARK;
3932         SV **svp;
3933         HE *he;
3934         bool preeminent = FALSE;
3935
3936         if (localizing) {
3937             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3938                 hv_exists_ent(hv, keysv, 0);
3939         }
3940
3941         he = hv_fetch_ent(hv, keysv, lval, 0);
3942         svp = he ? &HeVAL(he) : 0;
3943
3944         if (lval) {
3945             if (!svp || *svp == &PL_sv_undef) {
3946                 DIE(aTHX_ PL_no_helem_sv, keysv);
3947             }
3948             if (localizing) {
3949                 if (preeminent)
3950                     save_helem(hv, keysv, svp);
3951                 else {
3952                     STRLEN keylen;
3953                     const char *key = SvPV_const(keysv, keylen);
3954                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3955                 }
3956             }
3957         }
3958         *MARK = svp ? *svp : &PL_sv_undef;
3959     }
3960     if (GIMME != G_ARRAY) {
3961         MARK = ORIGMARK;
3962         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3963         SP = MARK;
3964     }
3965     RETURN;
3966 }
3967
3968 /* List operators. */
3969
3970 PP(pp_list)
3971 {
3972     dSP; dMARK;
3973     if (GIMME != G_ARRAY) {
3974         if (++MARK <= SP)
3975             *MARK = *SP;                /* unwanted list, return last item */
3976         else
3977             *MARK = &PL_sv_undef;
3978         SP = MARK;
3979     }
3980     RETURN;
3981 }
3982
3983 PP(pp_lslice)
3984 {
3985     dSP;
3986     SV ** const lastrelem = PL_stack_sp;
3987     SV ** const lastlelem = PL_stack_base + POPMARK;
3988     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3989     register SV ** const firstrelem = lastlelem + 1;
3990     const I32 arybase = PL_curcop->cop_arybase;
3991     I32 is_something_there = PL_op->op_flags & OPf_MOD;
3992
3993     register const I32 max = lastrelem - lastlelem;
3994     register SV **lelem;
3995
3996     if (GIMME != G_ARRAY) {
3997         I32 ix = SvIVx(*lastlelem);
3998         if (ix < 0)
3999             ix += max;
4000         else
4001             ix -= arybase;
4002         if (ix < 0 || ix >= max)
4003             *firstlelem = &PL_sv_undef;
4004         else
4005             *firstlelem = firstrelem[ix];
4006         SP = firstlelem;
4007         RETURN;
4008     }
4009
4010     if (max == 0) {
4011         SP = firstlelem - 1;
4012         RETURN;
4013     }
4014
4015     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4016         I32 ix = SvIVx(*lelem);
4017         if (ix < 0)
4018             ix += max;
4019         else
4020             ix -= arybase;
4021         if (ix < 0 || ix >= max)
4022             *lelem = &PL_sv_undef;
4023         else {
4024             is_something_there = TRUE;
4025             if (!(*lelem = firstrelem[ix]))
4026                 *lelem = &PL_sv_undef;
4027         }
4028     }
4029     if (is_something_there)
4030         SP = lastlelem;
4031     else
4032         SP = firstlelem - 1;
4033     RETURN;
4034 }
4035
4036 PP(pp_anonlist)
4037 {
4038     dSP; dMARK; dORIGMARK;
4039     const I32 items = SP - MARK;
4040     SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4041     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4042     XPUSHs(av);
4043     RETURN;
4044 }
4045
4046 PP(pp_anonhash)
4047 {
4048     dSP; dMARK; dORIGMARK;
4049     HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4050
4051     while (MARK < SP) {
4052         SV * const key = *++MARK;
4053         SV * const val = NEWSV(46, 0);
4054         if (MARK < SP)
4055             sv_setsv(val, *++MARK);
4056         else if (ckWARN(WARN_MISC))
4057             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4058         (void)hv_store_ent(hv,key,val,0);
4059     }
4060     SP = ORIGMARK;
4061     XPUSHs((SV*)hv);
4062     RETURN;
4063 }
4064
4065 PP(pp_splice)
4066 {
4067     dVAR; dSP; dMARK; dORIGMARK;
4068     register AV *ary = (AV*)*++MARK;
4069     register SV **src;
4070     register SV **dst;
4071     register I32 i;
4072     register I32 offset;
4073     register I32 length;
4074     I32 newlen;
4075     I32 after;
4076     I32 diff;
4077     SV **tmparyval = 0;
4078     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4079
4080     if (mg) {
4081         *MARK-- = SvTIED_obj((SV*)ary, mg);
4082         PUSHMARK(MARK);
4083         PUTBACK;
4084         ENTER;
4085         call_method("SPLICE",GIMME_V);
4086         LEAVE;
4087         SPAGAIN;
4088         RETURN;
4089     }
4090
4091     SP++;
4092
4093     if (++MARK < SP) {
4094         offset = i = SvIVx(*MARK);
4095         if (offset < 0)
4096             offset += AvFILLp(ary) + 1;
4097         else
4098             offset -= PL_curcop->cop_arybase;
4099         if (offset < 0)
4100             DIE(aTHX_ PL_no_aelem, i);
4101         if (++MARK < SP) {
4102             length = SvIVx(*MARK++);
4103             if (length < 0) {
4104                 length += AvFILLp(ary) - offset + 1;
4105                 if (length < 0)
4106                     length = 0;
4107             }
4108         }
4109         else
4110             length = AvMAX(ary) + 1;            /* close enough to infinity */
4111     }
4112     else {
4113         offset = 0;
4114         length = AvMAX(ary) + 1;
4115     }
4116     if (offset > AvFILLp(ary) + 1) {
4117         if (ckWARN(WARN_MISC))
4118             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4119         offset = AvFILLp(ary) + 1;
4120     }
4121     after = AvFILLp(ary) + 1 - (offset + length);
4122     if (after < 0) {                            /* not that much array */
4123         length += after;                        /* offset+length now in array */
4124         after = 0;
4125         if (!AvALLOC(ary))
4126             av_extend(ary, 0);
4127     }
4128
4129     /* At this point, MARK .. SP-1 is our new LIST */
4130
4131     newlen = SP - MARK;
4132     diff = newlen - length;
4133     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4134         av_reify(ary);
4135
4136     /* make new elements SVs now: avoid problems if they're from the array */
4137     for (dst = MARK, i = newlen; i; i--) {
4138         SV * const h = *dst;
4139         *dst++ = newSVsv(h);
4140     }
4141
4142     if (diff < 0) {                             /* shrinking the area */
4143         if (newlen) {
4144             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4145             Copy(MARK, tmparyval, newlen, SV*);
4146         }
4147
4148         MARK = ORIGMARK + 1;
4149         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4150             MEXTEND(MARK, length);
4151             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4152             if (AvREAL(ary)) {
4153                 EXTEND_MORTAL(length);
4154                 for (i = length, dst = MARK; i; i--) {
4155                     sv_2mortal(*dst);   /* free them eventualy */
4156                     dst++;
4157                 }
4158             }
4159             MARK += length - 1;
4160         }
4161         else {
4162             *MARK = AvARRAY(ary)[offset+length-1];
4163             if (AvREAL(ary)) {
4164                 sv_2mortal(*MARK);
4165                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4166                     SvREFCNT_dec(*dst++);       /* free them now */
4167             }
4168         }
4169         AvFILLp(ary) += diff;
4170
4171         /* pull up or down? */
4172
4173         if (offset < after) {                   /* easier to pull up */
4174             if (offset) {                       /* esp. if nothing to pull */
4175                 src = &AvARRAY(ary)[offset-1];
4176                 dst = src - diff;               /* diff is negative */
4177                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4178                     *dst-- = *src--;
4179             }
4180             dst = AvARRAY(ary);
4181             SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4182             AvMAX(ary) += diff;
4183         }
4184         else {
4185             if (after) {                        /* anything to pull down? */
4186                 src = AvARRAY(ary) + offset + length;
4187                 dst = src + diff;               /* diff is negative */
4188                 Move(src, dst, after, SV*);
4189             }
4190             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4191                                                 /* avoid later double free */
4192         }
4193         i = -diff;
4194         while (i)
4195             dst[--i] = &PL_sv_undef;
4196
4197         if (newlen) {
4198             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4199             Safefree(tmparyval);
4200         }
4201     }
4202     else {                                      /* no, expanding (or same) */
4203         if (length) {
4204             Newx(tmparyval, length, SV*);       /* so remember deletion */
4205             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4206         }
4207
4208         if (diff > 0) {                         /* expanding */
4209
4210             /* push up or down? */
4211
4212             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4213                 if (offset) {
4214                     src = AvARRAY(ary);
4215                     dst = src - diff;
4216                     Move(src, dst, offset, SV*);
4217                 }
4218                 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4219                 AvMAX(ary) += diff;
4220                 AvFILLp(ary) += diff;
4221             }
4222             else {
4223                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4224                     av_extend(ary, AvFILLp(ary) + diff);
4225                 AvFILLp(ary) += diff;
4226
4227                 if (after) {
4228                     dst = AvARRAY(ary) + AvFILLp(ary);
4229                     src = dst - diff;
4230                     for (i = after; i; i--) {
4231                         *dst-- = *src--;
4232                     }
4233                 }
4234             }
4235         }
4236
4237         if (newlen) {
4238             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4239         }
4240
4241         MARK = ORIGMARK + 1;
4242         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4243             if (length) {
4244                 Copy(tmparyval, MARK, length, SV*);
4245                 if (AvREAL(ary)) {
4246                     EXTEND_MORTAL(length);
4247                     for (i = length, dst = MARK; i; i--) {
4248                         sv_2mortal(*dst);       /* free them eventualy */
4249                         dst++;
4250                     }
4251                 }
4252                 Safefree(tmparyval);
4253             }
4254             MARK += length - 1;
4255         }
4256         else if (length--) {
4257             *MARK = tmparyval[length];
4258             if (AvREAL(ary)) {
4259                 sv_2mortal(*MARK);
4260                 while (length-- > 0)
4261                     SvREFCNT_dec(tmparyval[length]);
4262             }
4263             Safefree(tmparyval);
4264         }
4265         else
4266             *MARK = &PL_sv_undef;
4267     }
4268     SP = MARK;
4269     RETURN;
4270 }
4271
4272 PP(pp_push)
4273 {
4274     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4275     register AV *ary = (AV*)*++MARK;
4276     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4277
4278     if (mg) {
4279         *MARK-- = SvTIED_obj((SV*)ary, mg);
4280         PUSHMARK(MARK);
4281         PUTBACK;
4282         ENTER;
4283         call_method("PUSH",G_SCALAR|G_DISCARD);
4284         LEAVE;
4285         SPAGAIN;
4286         SP = ORIGMARK;
4287         PUSHi( AvFILL(ary) + 1 );
4288     }
4289     else {
4290         for (++MARK; MARK <= SP; MARK++) {
4291             SV * const sv = NEWSV(51, 0);
4292             if (*MARK)
4293                 sv_setsv(sv, *MARK);
4294             av_store(ary, AvFILLp(ary)+1, sv);
4295         }
4296         SP = ORIGMARK;
4297         PUSHi( AvFILLp(ary) + 1 );
4298     }
4299     RETURN;
4300 }
4301
4302 PP(pp_pop)
4303 {
4304     dSP;
4305     AV * const av = (AV*)POPs;
4306     SV * const sv = av_pop(av);
4307     if (AvREAL(av))
4308         (void)sv_2mortal(sv);
4309     PUSHs(sv);
4310     RETURN;
4311 }
4312
4313 PP(pp_shift)
4314 {
4315     dSP;
4316     AV * const av = (AV*)POPs;
4317     SV * const sv = av_shift(av);
4318     EXTEND(SP, 1);
4319     if (!sv)
4320         RETPUSHUNDEF;
4321     if (AvREAL(av))
4322         (void)sv_2mortal(sv);
4323     PUSHs(sv);
4324     RETURN;
4325 }
4326
4327 PP(pp_unshift)
4328 {
4329     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4330     register AV *ary = (AV*)*++MARK;
4331     const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4332
4333     if (mg) {
4334         *MARK-- = SvTIED_obj((SV*)ary, mg);
4335         PUSHMARK(MARK);
4336         PUTBACK;
4337         ENTER;
4338         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4339         LEAVE;
4340         SPAGAIN;
4341     }
4342     else {
4343         register I32 i = 0;
4344         av_unshift(ary, SP - MARK);
4345         while (MARK < SP) {
4346             SV * const sv = newSVsv(*++MARK);
4347             (void)av_store(ary, i++, sv);
4348         }
4349     }
4350     SP = ORIGMARK;
4351     PUSHi( AvFILL(ary) + 1 );
4352     RETURN;
4353 }
4354
4355 PP(pp_reverse)
4356 {
4357     dSP; dMARK;
4358     SV ** const oldsp = SP;
4359
4360     if (GIMME == G_ARRAY) {
4361         MARK++;
4362         while (MARK < SP) {
4363             register SV * const tmp = *MARK;
4364             *MARK++ = *SP;
4365             *SP-- = tmp;
4366         }
4367         /* safe as long as stack cannot get extended in the above */
4368         SP = oldsp;
4369     }
4370     else {
4371         register char *up;
4372         register char *down;
4373         register I32 tmp;
4374         dTARGET;
4375         STRLEN len;
4376         I32 padoff_du;
4377
4378         SvUTF8_off(TARG);                               /* decontaminate */
4379         if (SP - MARK > 1)
4380             do_join(TARG, &PL_sv_no, MARK, SP);
4381         else
4382             sv_setsv(TARG, (SP > MARK)
4383                     ? *SP
4384                     : (padoff_du = find_rundefsvoffset(),
4385                         (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4386                         ? DEFSV : PAD_SVl(padoff_du)));
4387         up = SvPV_force(TARG, len);
4388         if (len > 1) {
4389             if (DO_UTF8(TARG)) {        /* first reverse each character */
4390                 U8* s = (U8*)SvPVX(TARG);
4391                 const U8* send = (U8*)(s + len);
4392                 while (s < send) {
4393                     if (UTF8_IS_INVARIANT(*s)) {
4394                         s++;
4395                         continue;
4396                     }
4397                     else {
4398                         if (!utf8_to_uvchr(s, 0))
4399                             break;
4400                         up = (char*)s;
4401                         s += UTF8SKIP(s);
4402                         down = (char*)(s - 1);
4403                         /* reverse this character */
4404                         while (down > up) {
4405                             tmp = *up;
4406                             *up++ = *down;
4407                             *down-- = (char)tmp;
4408                         }
4409                     }
4410                 }
4411                 up = SvPVX(TARG);
4412             }
4413             down = SvPVX(TARG) + len - 1;
4414             while (down > up) {
4415                 tmp = *up;
4416                 *up++ = *down;
4417                 *down-- = (char)tmp;
4418             }
4419             (void)SvPOK_only_UTF8(TARG);
4420         }
4421         SP = MARK + 1;
4422         SETTARG;
4423     }
4424     RETURN;
4425 }
4426
4427 PP(pp_split)
4428 {
4429     dVAR; dSP; dTARG;
4430     AV *ary;
4431     register IV limit = POPi;                   /* note, negative is forever */
4432     SV * const sv = POPs;
4433     STRLEN len;
4434     register const char *s = SvPV_const(sv, len);
4435     const bool do_utf8 = DO_UTF8(sv);
4436     const char *strend = s + len;
4437     register PMOP *pm;
4438     register REGEXP *rx;
4439     register SV *dstr;
4440     register const char *m;
4441     I32 iters = 0;
4442     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4443     I32 maxiters = slen + 10;
4444     const char *orig;
4445     const I32 origlimit = limit;
4446     I32 realarray = 0;
4447     I32 base;
4448     const I32 gimme = GIMME_V;
4449     const I32 oldsave = PL_savestack_ix;
4450     I32 make_mortal = 1;
4451     bool multiline = 0;
4452     MAGIC *mg = (MAGIC *) NULL;
4453
4454 #ifdef DEBUGGING
4455     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4456 #else
4457     pm = (PMOP*)POPs;
4458 #endif
4459     if (!pm || !s)
4460         DIE(aTHX_ "panic: pp_split");
4461     rx = PM_GETRE(pm);
4462
4463     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4464              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4465
4466     RX_MATCH_UTF8_set(rx, do_utf8);
4467
4468     if (pm->op_pmreplroot) {
4469 #ifdef USE_ITHREADS
4470         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4471 #else
4472         ary = GvAVn((GV*)pm->op_pmreplroot);
4473 #endif
4474     }
4475     else if (gimme != G_ARRAY)
4476         ary = GvAVn(PL_defgv);
4477     else
4478         ary = Nullav;
4479     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4480         realarray = 1;
4481         PUTBACK;
4482         av_extend(ary,0);
4483         av_clear(ary);
4484         SPAGAIN;
4485         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4486             PUSHMARK(SP);
4487             XPUSHs(SvTIED_obj((SV*)ary, mg));
4488         }
4489         else {
4490             if (!AvREAL(ary)) {
4491                 I32 i;
4492                 AvREAL_on(ary);
4493                 AvREIFY_off(ary);
4494                 for (i = AvFILLp(ary); i >= 0; i--)
4495                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4496             }
4497             /* temporarily switch stacks */
4498             SAVESWITCHSTACK(PL_curstack, ary);
4499             make_mortal = 0;
4500         }
4501     }
4502     base = SP - PL_stack_base;
4503     orig = s;
4504     if (pm->op_pmflags & PMf_SKIPWHITE) {
4505         if (pm->op_pmflags & PMf_LOCALE) {
4506             while (isSPACE_LC(*s))
4507                 s++;
4508         }
4509         else {
4510             while (isSPACE(*s))
4511                 s++;
4512         }
4513     }
4514     if (pm->op_pmflags & PMf_MULTILINE) {
4515         multiline = 1;
4516     }
4517
4518     if (!limit)
4519         limit = maxiters + 2;
4520     if (pm->op_pmflags & PMf_WHITE) {
4521         while (--limit) {
4522             m = s;
4523             while (m < strend &&
4524                    !((pm->op_pmflags & PMf_LOCALE)
4525                      ? isSPACE_LC(*m) : isSPACE(*m)))
4526                 ++m;
4527             if (m >= strend)
4528                 break;
4529
4530             dstr = newSVpvn(s, m-s);
4531             if (make_mortal)
4532                 sv_2mortal(dstr);
4533             if (do_utf8)
4534                 (void)SvUTF8_on(dstr);
4535             XPUSHs(dstr);
4536
4537             s = m + 1;
4538             while (s < strend &&
4539                    ((pm->op_pmflags & PMf_LOCALE)
4540                     ? isSPACE_LC(*s) : isSPACE(*s)))
4541                 ++s;
4542         }
4543     }
4544     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4545         while (--limit) {
4546             for (m = s; m < strend && *m != '\n'; m++)
4547                 ;
4548             m++;
4549             if (m >= strend)
4550                 break;
4551             dstr = newSVpvn(s, m-s);
4552             if (make_mortal)
4553                 sv_2mortal(dstr);
4554             if (do_utf8)
4555                 (void)SvUTF8_on(dstr);
4556             XPUSHs(dstr);
4557             s = m;
4558         }
4559     }
4560     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4561              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4562              && (rx->reganch & ROPT_CHECK_ALL)
4563              && !(rx->reganch & ROPT_ANCH)) {
4564         const int tail = (rx->reganch & RE_INTUIT_TAIL);
4565         SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4566
4567         len = rx->minlen;
4568         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4569             const char c = *SvPV_nolen_const(csv);
4570             while (--limit) {
4571                 for (m = s; m < strend && *m != c; m++)
4572                     ;
4573                 if (m >= strend)
4574                     break;
4575                 dstr = newSVpvn(s, m-s);
4576                 if (make_mortal)
4577                     sv_2mortal(dstr);
4578                 if (do_utf8)
4579                     (void)SvUTF8_on(dstr);
4580                 XPUSHs(dstr);
4581                 /* The rx->minlen is in characters but we want to step
4582                  * s ahead by bytes. */
4583                 if (do_utf8)
4584                     s = (char*)utf8_hop((U8*)m, len);
4585                 else
4586                     s = m + len; /* Fake \n at the end */
4587             }
4588         }
4589         else {
4590             while (s < strend && --limit &&
4591               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4592                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4593             {
4594                 dstr = newSVpvn(s, m-s);
4595                 if (make_mortal)
4596                     sv_2mortal(dstr);
4597                 if (do_utf8)
4598                     (void)SvUTF8_on(dstr);
4599                 XPUSHs(dstr);
4600                 /* The rx->minlen is in characters but we want to step
4601                  * s ahead by bytes. */
4602                 if (do_utf8)
4603                     s = (char*)utf8_hop((U8*)m, len);
4604                 else
4605                     s = m + len; /* Fake \n at the end */
4606             }
4607         }
4608     }
4609     else {
4610         maxiters += slen * rx->nparens;
4611         while (s < strend && --limit)
4612         {
4613             I32 rex_return;
4614             PUTBACK;
4615             rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4616                             sv, NULL, 0);
4617             SPAGAIN;
4618             if (rex_return == 0)
4619                 break;
4620             TAINT_IF(RX_MATCH_TAINTED(rx));
4621             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4622                 m = s;
4623                 s = orig;
4624                 orig = rx->subbeg;
4625                 s = orig + (m - s);
4626                 strend = s + (strend - m);
4627             }
4628             m = rx->startp[0] + orig;
4629             dstr = newSVpvn(s, m-s);
4630             if (make_mortal)
4631                 sv_2mortal(dstr);
4632             if (do_utf8)
4633                 (void)SvUTF8_on(dstr);
4634             XPUSHs(dstr);
4635             if (rx->nparens) {
4636                 I32 i;
4637                 for (i = 1; i <= (I32)rx->nparens; i++) {
4638                     s = rx->startp[i] + orig;
4639                     m = rx->endp[i] + orig;
4640
4641                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4642                        parens that didn't match -- they should be set to
4643                        undef, not the empty string */
4644                     if (m >= orig && s >= orig) {
4645                         dstr = newSVpvn(s, m-s);
4646                     }
4647                     else
4648                         dstr = &PL_sv_undef;  /* undef, not "" */
4649                     if (make_mortal)
4650                         sv_2mortal(dstr);
4651                     if (do_utf8)
4652                         (void)SvUTF8_on(dstr);
4653                     XPUSHs(dstr);
4654                 }
4655             }
4656             s = rx->endp[0] + orig;
4657         }
4658     }
4659
4660     iters = (SP - PL_stack_base) - base;
4661     if (iters > maxiters)
4662         DIE(aTHX_ "Split loop");
4663
4664     /* keep field after final delim? */
4665     if (s < strend || (iters && origlimit)) {
4666         const STRLEN l = strend - s;
4667         dstr = newSVpvn(s, l);
4668         if (make_mortal)
4669             sv_2mortal(dstr);
4670         if (do_utf8)
4671             (void)SvUTF8_on(dstr);
4672         XPUSHs(dstr);
4673         iters++;
4674     }
4675     else if (!origlimit) {
4676         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4677             if (TOPs && !make_mortal)
4678                 sv_2mortal(TOPs);
4679             iters--;
4680             *SP-- = &PL_sv_undef;
4681         }
4682     }
4683
4684     PUTBACK;
4685     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4686     SPAGAIN;
4687     if (realarray) {
4688         if (!mg) {
4689             if (SvSMAGICAL(ary)) {
4690                 PUTBACK;
4691                 mg_set((SV*)ary);
4692                 SPAGAIN;
4693             }
4694             if (gimme == G_ARRAY) {
4695                 EXTEND(SP, iters);
4696                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4697                 SP += iters;
4698                 RETURN;
4699             }
4700         }
4701         else {
4702             PUTBACK;
4703             ENTER;
4704             call_method("PUSH",G_SCALAR|G_DISCARD);
4705             LEAVE;
4706             SPAGAIN;
4707             if (gimme == G_ARRAY) {
4708                 I32 i;
4709                 /* EXTEND should not be needed - we just popped them */
4710                 EXTEND(SP, iters);
4711                 for (i=0; i < iters; i++) {
4712                     SV **svp = av_fetch(ary, i, FALSE);
4713                     PUSHs((svp) ? *svp : &PL_sv_undef);
4714                 }
4715                 RETURN;
4716             }
4717         }
4718     }
4719     else {
4720         if (gimme == G_ARRAY)
4721             RETURN;
4722     }
4723
4724     GETTARGET;
4725     PUSHi(iters);
4726     RETURN;
4727 }
4728
4729 PP(pp_lock)
4730 {
4731     dSP;
4732     dTOPss;
4733     SV *retsv = sv;
4734     SvLOCK(sv);
4735     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4736         || SvTYPE(retsv) == SVt_PVCV) {
4737         retsv = refto(retsv);
4738     }
4739     SETs(retsv);
4740     RETURN;
4741 }
4742
4743
4744 PP(unimplemented_op)
4745 {
4746     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4747         PL_op->op_type);
4748 }
4749
4750 /*
4751  * Local variables:
4752  * c-indentation-style: bsd
4753  * c-basic-offset: 4
4754  * indent-tabs-mode: t
4755  * End:
4756  *
4757  * ex: set ts=8 sts=4 sw=4 noet:
4758  */