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