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