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