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