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 /* variations on pp_null */
  39
  40 PP(pp_stub)
  41 {
  42     dSP;
  43     if (GIMME_V == G_SCALAR)
  44         XPUSHs(&PL_sv_undef);
  45     RETURN;
  46 }
  47
  48 PP(pp_scalar)
  49 {
  50     return NORMAL;
  51 }
  52
  53 /* Pushy stuff. */
  54
  55 PP(pp_padav)
  56 {
  57     dSP; dTARGET;
  58     I32 gimme;
  59     if (PL_op->op_private & OPpLVAL_INTRO)
  60         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  61     EXTEND(SP, 1);
  62     if (PL_op->op_flags & OPf_REF) {
  63         PUSHs(TARG);
  64         RETURN;
  65     } else if (LVRET) {
  66         if (GIMME == G_SCALAR)
  67             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  68         PUSHs(TARG);
  69         RETURN;
  70     }
  71     gimme = GIMME_V;
  72     if (gimme == G_ARRAY) {
  73         I32 maxarg = AvFILL((AV*)TARG) + 1;
  74         EXTEND(SP, maxarg);
  75         if (SvMAGICAL(TARG)) {
  76             U32 i;
  77             for (i=0; i < (U32)maxarg; i++) {
  78                 SV **svp = av_fetch((AV*)TARG, i, FALSE);
  79                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  80             }
  81         }
  82         else {
  83             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
  84         }
  85         SP += maxarg;
  86     }
  87     else if (gimme == G_SCALAR) {
  88         SV* sv = sv_newmortal();
  89         I32 maxarg = AvFILL((AV*)TARG) + 1;
  90         sv_setiv(sv, maxarg);
  91         PUSHs(sv);
  92     }
  93     RETURN;
  94 }
  95
  96 PP(pp_padhv)
  97 {
  98     dSP; dTARGET;
  99     I32 gimme;
 100
 101     XPUSHs(TARG);
 102     if (PL_op->op_private & OPpLVAL_INTRO)
 103         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 104     if (PL_op->op_flags & OPf_REF)
 105         RETURN;
 106     else if (LVRET) {
 107         if (GIMME == G_SCALAR)
 108             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 109         RETURN;
 110     }
 111     gimme = GIMME_V;
 112     if (gimme == G_ARRAY) {
 113         RETURNOP(do_kv());
 114     }
 115     else if (gimme == G_SCALAR) {
 116         SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
 117         SETs(sv);
 118     }
 119     RETURN;
 120 }
 121
 122 PP(pp_padany)
 123 {
 124     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
 125 }
 126
 127 /* Translations. */
 128
 129 PP(pp_rv2gv)
 130 {
 131     dSP; dTOPss;
 132
 133     if (SvROK(sv)) {
 134       wasref:
 135         tryAMAGICunDEREF(to_gv);
 136
 137         sv = SvRV(sv);
 138         if (SvTYPE(sv) == SVt_PVIO) {
 139             GV *gv = (GV*) sv_newmortal();
 140             gv_init(gv, 0, "", 0, 0);
 141             GvIOp(gv) = (IO *)sv;
 142             (void)SvREFCNT_inc(sv);
 143             sv = (SV*) gv;
 144         }
 145         else if (SvTYPE(sv) != SVt_PVGV)
 146             DIE(aTHX_ "Not a GLOB reference");
 147     }
 148     else {
 149         if (SvTYPE(sv) != SVt_PVGV) {
 150             char *sym;
 151             STRLEN len;
 152
 153             if (SvGMAGICAL(sv)) {
 154                 mg_get(sv);
 155                 if (SvROK(sv))
 156                     goto wasref;
 157             }
 158             if (!SvOK(sv) && sv != &PL_sv_undef) {
 159                 /* If this is a 'my' scalar and flag is set then vivify
 160                  * NI-S 1999/05/07
 161                  */
 162                 if (SvREADONLY(sv))
 163                     Perl_croak(aTHX_ PL_no_modify);
 164                 if (PL_op->op_private & OPpDEREF) {
 165                     char *name;
 166                     GV *gv;
 167                     if (cUNOP->op_targ) {
 168                         STRLEN len;
 169                         SV *namesv = PAD_SV(cUNOP->op_targ);
 170                         name = SvPV(namesv, len);
 171                         gv = (GV*)NEWSV(0,0);
 172                         gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
 173                     }
 174                     else {
 175                         name = CopSTASHPV(PL_curcop);
 176                         gv = newGVgen(name);
 177                     }
 178                     if (SvTYPE(sv) < SVt_RV)
 179                         sv_upgrade(sv, SVt_RV);
 180                     if (SvPVX(sv)) {
 181                         SvOOK_off(sv);          /* backoff */
 182                         if (SvLEN(sv))
 183                             Safefree(SvPVX(sv));
 184                         SvLEN(sv)=SvCUR(sv)=0;
 185                     }
 186                     SvRV(sv) = (SV*)gv;
 187                     SvROK_on(sv);
 188                     SvSETMAGIC(sv);
 189                     goto wasref;
 190                 }
 191                 if (PL_op->op_flags & OPf_REF ||
 192                     PL_op->op_private & HINT_STRICT_REFS)
 193                     DIE(aTHX_ PL_no_usym, "a symbol");
 194                 if (ckWARN(WARN_UNINITIALIZED))
 195                     report_uninit(sv);
 196                 RETSETUNDEF;
 197             }
 198             sym = SvPV(sv,len);
 199             if ((PL_op->op_flags & OPf_SPECIAL) &&
 200                 !(PL_op->op_flags & OPf_MOD))
 201             {
 202                 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
 203                 if (!sv
 204                     && (!is_gv_magical(sym,len,0)
 205                         || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
 206                 {
 207                     RETSETUNDEF;
 208                 }
 209             }
 210             else {
 211                 if (PL_op->op_private & HINT_STRICT_REFS)
 212                     DIE(aTHX_ PL_no_symref, sym, "a symbol");
 213                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
 214             }
 215         }
 216     }
 217     if (PL_op->op_private & OPpLVAL_INTRO)
 218         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 219     SETs(sv);
 220     RETURN;
 221 }
 222
 223 PP(pp_rv2sv)
 224 {
 225     GV *gv = Nullgv;
 226     dSP; dTOPss;
 227
 228     if (SvROK(sv)) {
 229       wasref:
 230         tryAMAGICunDEREF(to_sv);
 231
 232         sv = SvRV(sv);
 233         switch (SvTYPE(sv)) {
 234         case SVt_PVAV:
 235         case SVt_PVHV:
 236         case SVt_PVCV:
 237             DIE(aTHX_ "Not a SCALAR reference");
 238         }
 239     }
 240     else {
 241         char *sym;
 242         STRLEN len;
 243         gv = (GV*)sv;
 244
 245         if (SvTYPE(gv) != SVt_PVGV) {
 246             if (SvGMAGICAL(sv)) {
 247                 mg_get(sv);
 248                 if (SvROK(sv))
 249                     goto wasref;
 250             }
 251             if (!SvOK(sv)) {
 252                 if (PL_op->op_flags & OPf_REF ||
 253                     PL_op->op_private & HINT_STRICT_REFS)
 254                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 255                 if (ckWARN(WARN_UNINITIALIZED))
 256                     report_uninit(sv);
 257                 RETSETUNDEF;
 258             }
 259             sym = SvPV(sv, len);
 260             if ((PL_op->op_flags & OPf_SPECIAL) &&
 261                 !(PL_op->op_flags & OPf_MOD))
 262             {
 263                 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
 264                 if (!gv
 265                     && (!is_gv_magical(sym,len,0)
 266                         || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
 267                 {
 268                     RETSETUNDEF;
 269                 }
 270             }
 271             else {
 272                 if (PL_op->op_private & HINT_STRICT_REFS)
 273                     DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
 274                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
 275             }
 276         }
 277         sv = GvSV(gv);
 278     }
 279     if (PL_op->op_flags & OPf_MOD) {
 280         if (PL_op->op_private & OPpLVAL_INTRO) {
 281             if (cUNOP->op_first->op_type == OP_NULL)
 282                 sv = save_scalar((GV*)TOPs);
 283             else if (gv)
 284                 sv = save_scalar(gv);
 285             else
 286                 Perl_croak(aTHX_ PL_no_localize_ref);
 287         }
 288         else if (PL_op->op_private & OPpDEREF)
 289             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 290     }
 291     SETs(sv);
 292     RETURN;
 293 }
 294
 295 PP(pp_av2arylen)
 296 {
 297     dSP;
 298     AV *av = (AV*)TOPs;
 299     SV *sv = AvARYLEN(av);
 300     if (!sv) {
 301         AvARYLEN(av) = sv = NEWSV(0,0);
 302         sv_upgrade(sv, SVt_IV);
 303         sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
 304     }
 305     SETs(sv);
 306     RETURN;
 307 }
 308
 309 PP(pp_pos)
 310 {
 311     dSP; dTARGET; dPOPss;
 312
 313     if (PL_op->op_flags & OPf_MOD || LVRET) {
 314         if (SvTYPE(TARG) < SVt_PVLV) {
 315             sv_upgrade(TARG, SVt_PVLV);
 316             sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
 317         }
 318
 319         LvTYPE(TARG) = '.';
 320         if (LvTARG(TARG) != sv) {
 321             if (LvTARG(TARG))
 322                 SvREFCNT_dec(LvTARG(TARG));
 323             LvTARG(TARG) = SvREFCNT_inc(sv);
 324         }
 325         PUSHs(TARG);    /* no SvSETMAGIC */
 326         RETURN;
 327     }
 328     else {
 329         MAGIC* mg;
 330
 331         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 332             mg = mg_find(sv, PERL_MAGIC_regex_global);
 333             if (mg && mg->mg_len >= 0) {
 334                 I32 i = mg->mg_len;
 335                 if (DO_UTF8(sv))
 336                     sv_pos_b2u(sv, &i);
 337                 PUSHi(i + PL_curcop->cop_arybase);
 338                 RETURN;
 339             }
 340         }
 341         RETPUSHUNDEF;
 342     }
 343 }
 344
 345 PP(pp_rv2cv)
 346 {
 347     dSP;
 348     GV *gv;
 349     HV *stash;
 350
 351     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 352     /* (But not in defined().) */
 353     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
 354     if (cv) {
 355         if (CvCLONE(cv))
 356             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 357         if ((PL_op->op_private & OPpLVAL_INTRO)) {
 358             if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
 359                 cv = GvCV(gv);
 360             if (!CvLVALUE(cv))
 361                 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 362         }
 363     }
 364     else
 365         cv = (CV*)&PL_sv_undef;
 366     SETs((SV*)cv);
 367     RETURN;
 368 }
 369
 370 PP(pp_prototype)
 371 {
 372     dSP;
 373     CV *cv;
 374     HV *stash;
 375     GV *gv;
 376     SV *ret;
 377
 378     ret = &PL_sv_undef;
 379     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 380         char *s = SvPVX(TOPs);
 381         if (strnEQ(s, "CORE::", 6)) {
 382             int code;
 383
 384             code = keyword(s + 6, SvCUR(TOPs) - 6);
 385             if (code < 0) {     /* Overridable. */
 386 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 387                 int i = 0, n = 0, seen_question = 0;
 388                 I32 oa;
 389                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 390
 391                 if (code == -KEY_chop || code == -KEY_chomp)
 392                     goto set;
 393                 while (i < MAXO) {      /* The slow way. */
 394                     if (strEQ(s + 6, PL_op_name[i])
 395                         || strEQ(s + 6, PL_op_desc[i]))
 396                     {
 397                         goto found;
 398                     }
 399                     i++;
 400                 }
 401                 goto nonesuch;          /* Should not happen... */
 402               found:
 403                 oa = PL_opargs[i] >> OASHIFT;
 404                 while (oa) {
 405                     if (oa & OA_OPTIONAL && !seen_question) {
 406                         seen_question = 1;
 407                         str[n++] = ';';
 408                     }
 409                     else if (n && str[0] == ';' && seen_question)
 410                         goto set;       /* XXXX system, exec */
 411                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 412                         && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
 413                         /* But globs are already references (kinda) */
 414                         && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
 415                     ) {
 416                         str[n++] = '\\';
 417                     }
 418                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 419                     oa = oa >> 4;
 420                 }
 421                 str[n++] = '\0';
 422                 ret = sv_2mortal(newSVpvn(str, n - 1));
 423             }
 424             else if (code)              /* Non-Overridable */
 425                 goto set;
 426             else {                      /* None such */
 427               nonesuch:
 428                 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 429             }
 430         }
 431     }
 432     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 433     if (cv && SvPOK(cv))
 434         ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
 435   set:
 436     SETs(ret);
 437     RETURN;
 438 }
 439
 440 PP(pp_anoncode)
 441 {
 442     dSP;
 443     CV* cv = (CV*)PAD_SV(PL_op->op_targ);
 444     if (CvCLONE(cv))
 445         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 446     EXTEND(SP,1);
 447     PUSHs((SV*)cv);
 448     RETURN;
 449 }
 450
 451 PP(pp_srefgen)
 452 {
 453     dSP;
 454     *SP = refto(*SP);
 455     RETURN;
 456 }
 457
 458 PP(pp_refgen)
 459 {
 460     dSP; dMARK;
 461     if (GIMME != G_ARRAY) {
 462         if (++MARK <= SP)
 463             *MARK = *SP;
 464         else
 465             *MARK = &PL_sv_undef;
 466         *MARK = refto(*MARK);
 467         SP = MARK;
 468         RETURN;
 469     }
 470     EXTEND_MORTAL(SP - MARK);
 471     while (++MARK <= SP)
 472         *MARK = refto(*MARK);
 473     RETURN;
 474 }
 475
 476 STATIC SV*
 477 S_refto(pTHX_ SV *sv)
 478 {
 479     SV* rv;
 480
 481     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 482         if (LvTARGLEN(sv))
 483             vivify_defelem(sv);
 484         if (!(sv = LvTARG(sv)))
 485             sv = &PL_sv_undef;
 486         else
 487             (void)SvREFCNT_inc(sv);
 488     }
 489     else if (SvTYPE(sv) == SVt_PVAV) {
 490         if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
 491             av_reify((AV*)sv);
 492         SvTEMP_off(sv);
 493         (void)SvREFCNT_inc(sv);
 494     }
 495     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 496         sv = newSVsv(sv);
 497     else {
 498         SvTEMP_off(sv);
 499         (void)SvREFCNT_inc(sv);
 500     }
 501     rv = sv_newmortal();
 502     sv_upgrade(rv, SVt_RV);
 503     SvRV(rv) = sv;
 504     SvROK_on(rv);
 505     return rv;
 506 }
 507
 508 PP(pp_ref)
 509 {
 510     dSP; dTARGET;
 511     SV *sv;
 512     char *pv;
 513
 514     sv = POPs;
 515
 516     if (sv && SvGMAGICAL(sv))
 517         mg_get(sv);
 518
 519     if (!sv || !SvROK(sv))
 520         RETPUSHNO;
 521
 522     sv = SvRV(sv);
 523     pv = sv_reftype(sv,TRUE);
 524     PUSHp(pv, strlen(pv));
 525     RETURN;
 526 }
 527
 528 PP(pp_bless)
 529 {
 530     dSP;
 531     HV *stash;
 532
 533     if (MAXARG == 1)
 534         stash = CopSTASH(PL_curcop);
 535     else {
 536         SV *ssv = POPs;
 537         STRLEN len;
 538         char *ptr;
 539
 540         if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 541             Perl_croak(aTHX_ "Attempt to bless into a reference");
 542         ptr = SvPV(ssv,len);
 543         if (ckWARN(WARN_MISC) && len == 0)
 544             Perl_warner(aTHX_ packWARN(WARN_MISC),
 545                    "Explicit blessing to '' (assuming package main)");
 546         stash = gv_stashpvn(ptr, len, TRUE);
 547     }
 548
 549     (void)sv_bless(TOPs, stash);
 550     RETURN;
 551 }
 552
 553 PP(pp_gelem)
 554 {
 555     GV *gv;
 556     SV *sv;
 557     SV *tmpRef;
 558     char *elem;
 559     dSP;
 560     STRLEN n_a;
 561
 562     sv = POPs;
 563     elem = SvPV(sv, n_a);
 564     gv = (GV*)POPs;
 565     tmpRef = Nullsv;
 566     sv = Nullsv;
 567     if (elem) {
 568         /* elem will always be NUL terminated.  */
 569         const char *elem2 = elem + 1;
 570         switch (*elem) {
 571         case 'A':
 572             if (strEQ(elem2, "RRAY"))
 573                 tmpRef = (SV*)GvAV(gv);
 574             break;
 575         case 'C':
 576             if (strEQ(elem2, "ODE"))
 577                 tmpRef = (SV*)GvCVu(gv);
 578             break;
 579         case 'F':
 580             if (strEQ(elem2, "ILEHANDLE")) {
 581                 /* finally deprecated in 5.8.0 */
 582                 deprecate("*glob{FILEHANDLE}");
 583                 tmpRef = (SV*)GvIOp(gv);
 584             }
 585             else
 586                 if (strEQ(elem2, "ORMAT"))
 587                     tmpRef = (SV*)GvFORM(gv);
 588             break;
 589         case 'G':
 590             if (strEQ(elem2, "LOB"))
 591                 tmpRef = (SV*)gv;
 592             break;
 593         case 'H':
 594             if (strEQ(elem2, "ASH"))
 595                 tmpRef = (SV*)GvHV(gv);
 596             break;
 597         case 'I':
 598             if (*elem2 == 'O' && !elem[2])
 599                 tmpRef = (SV*)GvIOp(gv);
 600             break;
 601         case 'N':
 602             if (strEQ(elem2, "AME"))
 603                 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 604             break;
 605         case 'P':
 606             if (strEQ(elem2, "ACKAGE")) {
 607                 if (HvNAME(GvSTASH(gv)))
 608                     sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 609                 else
 610                     sv = newSVpv("__ANON__",0);
 611             }
 612             break;
 613         case 'S':
 614             if (strEQ(elem2, "CALAR"))
 615                 tmpRef = GvSV(gv);
 616             break;
 617         }
 618     }
 619     if (tmpRef)
 620         sv = newRV(tmpRef);
 621     if (sv)
 622         sv_2mortal(sv);
 623     else
 624         sv = &PL_sv_undef;
 625     XPUSHs(sv);
 626     RETURN;
 627 }
 628
 629 /* Pattern matching */
 630
 631 PP(pp_study)
 632 {
 633     dSP; dPOPss;
 634     register unsigned char *s;
 635     register I32 pos;
 636     register I32 ch;
 637     register I32 *sfirst;
 638     register I32 *snext;
 639     STRLEN len;
 640
 641     if (sv == PL_lastscream) {
 642         if (SvSCREAM(sv))
 643             RETPUSHYES;
 644     }
 645     else {
 646         if (PL_lastscream) {
 647             SvSCREAM_off(PL_lastscream);
 648             SvREFCNT_dec(PL_lastscream);
 649         }
 650         PL_lastscream = SvREFCNT_inc(sv);
 651     }
 652
 653     s = (unsigned char*)(SvPV(sv, len));
 654     pos = len;
 655     if (pos <= 0)
 656         RETPUSHNO;
 657     if (pos > PL_maxscream) {
 658         if (PL_maxscream < 0) {
 659             PL_maxscream = pos + 80;
 660             New(301, PL_screamfirst, 256, I32);
 661             New(302, PL_screamnext, PL_maxscream, I32);
 662         }
 663         else {
 664             PL_maxscream = pos + pos / 4;
 665             Renew(PL_screamnext, PL_maxscream, I32);
 666         }
 667     }
 668
 669     sfirst = PL_screamfirst;
 670     snext = PL_screamnext;
 671
 672     if (!sfirst || !snext)
 673         DIE(aTHX_ "do_study: out of memory");
 674
 675     for (ch = 256; ch; --ch)
 676         *sfirst++ = -1;
 677     sfirst -= 256;
 678
 679     while (--pos >= 0) {
 680         ch = s[pos];
 681         if (sfirst[ch] >= 0)
 682             snext[pos] = sfirst[ch] - pos;
 683         else
 684             snext[pos] = -pos;
 685         sfirst[ch] = pos;
 686     }
 687
 688     SvSCREAM_on(sv);
 689     /* piggyback on m//g magic */
 690     sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 691     RETPUSHYES;
 692 }
 693
 694 PP(pp_trans)
 695 {
 696     dSP; dTARG;
 697     SV *sv;
 698
 699     if (PL_op->op_flags & OPf_STACKED)
 700         sv = POPs;
 701     else if (PL_op->op_private & OPpTARGET_MY)
 702         sv = GETTARGET;
 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     SV_CHECK_THINKFIRST_COW_DROP(sv);
 797
 798     switch (SvTYPE(sv)) {
 799     case SVt_NULL:
 800         break;
 801     case SVt_PVAV:
 802         av_undef((AV*)sv);
 803         break;
 804     case SVt_PVHV:
 805         hv_undef((HV*)sv);
 806         break;
 807     case SVt_PVCV:
 808         if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
 809             Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
 810                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 811         /* FALL THROUGH */
 812     case SVt_PVFM:
 813         {
 814             /* let user-undef'd sub keep its identity */
 815             GV* gv = CvGV((CV*)sv);
 816             cv_undef((CV*)sv);
 817             CvGV((CV*)sv) = gv;
 818         }
 819         break;
 820     case SVt_PVGV:
 821         if (SvFAKE(sv))
 822             SvSetMagicSV(sv, &PL_sv_undef);
 823         else {
 824             GP *gp;
 825             gp_free((GV*)sv);
 826             Newz(602, gp, 1, GP);
 827             GvGP(sv) = gp_ref(gp);
 828             GvSV(sv) = NEWSV(72,0);
 829             GvLINE(sv) = CopLINE(PL_curcop);
 830             GvEGV(sv) = (GV*)sv;
 831             GvMULTI_on(sv);
 832         }
 833         break;
 834     default:
 835         if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
 836             SvOOK_off(sv);
 837             Safefree(SvPVX(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_PVGV && 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         --SvIVX(TOPs);
 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_PVGV && 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         ++SvIVX(TOPs);
 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_PVGV && 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         --SvIVX(TOPs);
 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                 IV max = 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, (count * len) + 1);
1505                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1506                 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 (SvGMAGICAL(left)) mg_get(left);
2263       if (SvGMAGICAL(right)) mg_get(right);
2264       if (SvNIOKp(left) || SvNIOKp(right)) {
2265         if (PL_op->op_private & HINT_INTEGER) {
2266           IV i = SvIV_nomg(left) & SvIV_nomg(right);
2267           SETi(i);
2268         }
2269         else {
2270           UV u = SvUV_nomg(left) & SvUV_nomg(right);
2271           SETu(u);
2272         }
2273       }
2274       else {
2275         do_vop(PL_op->op_type, TARG, left, right);
2276         SETTARG;
2277       }
2278       RETURN;
2279     }
2280 }
2281
2282 PP(pp_bit_xor)
2283 {
2284     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2285     {
2286       dPOPTOPssrl;
2287       if (SvGMAGICAL(left)) mg_get(left);
2288       if (SvGMAGICAL(right)) mg_get(right);
2289       if (SvNIOKp(left) || SvNIOKp(right)) {
2290         if (PL_op->op_private & HINT_INTEGER) {
2291           IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2292           SETi(i);
2293         }
2294         else {
2295           UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2296           SETu(u);
2297         }
2298       }
2299       else {
2300         do_vop(PL_op->op_type, TARG, left, right);
2301         SETTARG;
2302       }
2303       RETURN;
2304     }
2305 }
2306
2307 PP(pp_bit_or)
2308 {
2309     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2310     {
2311       dPOPTOPssrl;
2312       if (SvGMAGICAL(left)) mg_get(left);
2313       if (SvGMAGICAL(right)) mg_get(right);
2314       if (SvNIOKp(left) || SvNIOKp(right)) {
2315         if (PL_op->op_private & HINT_INTEGER) {
2316           IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2317           SETi(i);
2318         }
2319         else {
2320           UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2321           SETu(u);
2322         }
2323       }
2324       else {
2325         do_vop(PL_op->op_type, TARG, left, right);
2326         SETTARG;
2327       }
2328       RETURN;
2329     }
2330 }
2331
2332 PP(pp_negate)
2333 {
2334     dSP; dTARGET; tryAMAGICun(neg);
2335     {
2336         dTOPss;
2337         int flags = SvFLAGS(sv);
2338         if (SvGMAGICAL(sv))
2339             mg_get(sv);
2340         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2341             /* It's publicly an integer, or privately an integer-not-float */
2342         oops_its_an_int:
2343             if (SvIsUV(sv)) {
2344                 if (SvIVX(sv) == IV_MIN) {
2345                     /* 2s complement assumption. */
2346                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2347                     RETURN;
2348                 }
2349                 else if (SvUVX(sv) <= IV_MAX) {
2350                     SETi(-SvIVX(sv));
2351                     RETURN;
2352                 }
2353             }
2354             else if (SvIVX(sv) != IV_MIN) {
2355                 SETi(-SvIVX(sv));
2356                 RETURN;
2357             }
2358 #ifdef PERL_PRESERVE_IVUV
2359             else {
2360                 SETu((UV)IV_MIN);
2361                 RETURN;
2362             }
2363 #endif
2364         }
2365         if (SvNIOKp(sv))
2366             SETn(-SvNV(sv));
2367         else if (SvPOKp(sv)) {
2368             STRLEN len;
2369             char *s = SvPV(sv, len);
2370             if (isIDFIRST(*s)) {
2371                 sv_setpvn(TARG, "-", 1);
2372                 sv_catsv(TARG, sv);
2373             }
2374             else if (*s == '+' || *s == '-') {
2375                 sv_setsv(TARG, sv);
2376                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2377             }
2378             else if (DO_UTF8(sv)) {
2379                 SvIV_please(sv);
2380                 if (SvIOK(sv))
2381                     goto oops_its_an_int;
2382                 if (SvNOK(sv))
2383                     sv_setnv(TARG, -SvNV(sv));
2384                 else {
2385                     sv_setpvn(TARG, "-", 1);
2386                     sv_catsv(TARG, sv);
2387                 }
2388             }
2389             else {
2390                 SvIV_please(sv);
2391                 if (SvIOK(sv))
2392                   goto oops_its_an_int;
2393                 sv_setnv(TARG, -SvNV(sv));
2394             }
2395             SETTARG;
2396         }
2397         else
2398             SETn(-SvNV(sv));
2399     }
2400     RETURN;
2401 }
2402
2403 PP(pp_not)
2404 {
2405     dSP; tryAMAGICunSET(not);
2406     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2407     return NORMAL;
2408 }
2409
2410 PP(pp_complement)
2411 {
2412     dSP; dTARGET; tryAMAGICun(compl);
2413     {
2414       dTOPss;
2415       if (SvGMAGICAL(sv))
2416           mg_get(sv);
2417       if (SvNIOKp(sv)) {
2418         if (PL_op->op_private & HINT_INTEGER) {
2419           IV i = ~SvIV_nomg(sv);
2420           SETi(i);
2421         }
2422         else {
2423           UV u = ~SvUV_nomg(sv);
2424           SETu(u);
2425         }
2426       }
2427       else {
2428         register U8 *tmps;
2429         register I32 anum;
2430         STRLEN len;
2431
2432         (void)SvPV_nomg(sv,len); /* force check for uninit var */
2433         sv_setsv_nomg(TARG, sv);
2434         tmps = (U8*)SvPV_force(TARG, len);
2435         anum = len;
2436         if (SvUTF8(TARG)) {
2437           /* Calculate exact length, let's not estimate. */
2438           STRLEN targlen = 0;
2439           U8 *result;
2440           U8 *send;
2441           STRLEN l;
2442           UV nchar = 0;
2443           UV nwide = 0;
2444
2445           send = tmps + len;
2446           while (tmps < send) {
2447             UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2448             tmps += UTF8SKIP(tmps);
2449             targlen += UNISKIP(~c);
2450             nchar++;
2451             if (c > 0xff)
2452                 nwide++;
2453           }
2454
2455           /* Now rewind strings and write them. */
2456           tmps -= len;
2457
2458           if (nwide) {
2459               Newz(0, result, targlen + 1, U8);
2460               while (tmps < send) {
2461                   UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2462                   tmps += UTF8SKIP(tmps);
2463                   result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2464               }
2465               *result = '\0';
2466               result -= targlen;
2467               sv_setpvn(TARG, (char*)result, targlen);
2468               SvUTF8_on(TARG);
2469           }
2470           else {
2471               Newz(0, result, nchar + 1, U8);
2472               while (tmps < send) {
2473                   U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2474                   tmps += UTF8SKIP(tmps);
2475                   *result++ = ~c;
2476               }
2477               *result = '\0';
2478               result -= nchar;
2479               sv_setpvn(TARG, (char*)result, nchar);
2480               SvUTF8_off(TARG);
2481           }
2482           Safefree(result);
2483           SETs(TARG);
2484           RETURN;
2485         }
2486 #ifdef LIBERAL
2487         {
2488             register long *tmpl;
2489             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2490                 *tmps = ~*tmps;
2491             tmpl = (long*)tmps;
2492             for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2493                 *tmpl = ~*tmpl;
2494             tmps = (U8*)tmpl;
2495         }
2496 #endif
2497         for ( ; anum > 0; anum--, tmps++)
2498             *tmps = ~*tmps;
2499
2500         SETs(TARG);
2501       }
2502       RETURN;
2503     }
2504 }
2505
2506 /* integer versions of some of the above */
2507
2508 PP(pp_i_multiply)
2509 {
2510     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2511     {
2512       dPOPTOPiirl;
2513       SETi( left * right );
2514       RETURN;
2515     }
2516 }
2517
2518 PP(pp_i_divide)
2519 {
2520     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2521     {
2522       dPOPiv;
2523       if (value == 0)
2524         DIE(aTHX_ "Illegal division by zero");
2525       value = POPi / value;
2526       PUSHi( value );
2527       RETURN;
2528     }
2529 }
2530
2531 STATIC
2532 PP(pp_i_modulo_0)
2533 {
2534      /* This is the vanilla old i_modulo. */
2535      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2536      {
2537           dPOPTOPiirl;
2538           if (!right)
2539                DIE(aTHX_ "Illegal modulus zero");
2540           SETi( left % right );
2541           RETURN;
2542      }
2543 }
2544
2545 #if defined(__GLIBC__) && IVSIZE == 8
2546 STATIC
2547 PP(pp_i_modulo_1)
2548 {
2549      /* This is the i_modulo with the workaround for the _moddi3 bug
2550       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2551       * See below for pp_i_modulo. */
2552      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2553      {
2554           dPOPTOPiirl;
2555           if (!right)
2556                DIE(aTHX_ "Illegal modulus zero");
2557           SETi( left % PERL_ABS(right) );
2558           RETURN;
2559      }
2560 }
2561 #endif
2562
2563 PP(pp_i_modulo)
2564 {
2565      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2566      {
2567           dPOPTOPiirl;
2568           if (!right)
2569                DIE(aTHX_ "Illegal modulus zero");
2570           /* The assumption is to use hereafter the old vanilla version... */
2571           PL_op->op_ppaddr =
2572                PL_ppaddr[OP_I_MODULO] =
2573                    &Perl_pp_i_modulo_0;
2574           /* .. but if we have glibc, we might have a buggy _moddi3
2575            * (at least glicb 2.2.5 is known to have this bug), in other
2576            * words our integer modulus with negative quad as the second
2577            * argument might be broken.  Test for this and re-patch the
2578            * opcode dispatch table if that is the case, remembering to
2579            * also apply the workaround so that this first round works
2580            * right, too.  See [perl #9402] for more information. */
2581 #if defined(__GLIBC__) && IVSIZE == 8
2582           {
2583                IV l =   3;
2584                IV r = -10;
2585                /* Cannot do this check with inlined IV constants since
2586                 * that seems to work correctly even with the buggy glibc. */
2587                if (l % r == -3) {
2588                     /* Yikes, we have the bug.
2589                      * Patch in the workaround version. */
2590                     PL_op->op_ppaddr =
2591                          PL_ppaddr[OP_I_MODULO] =
2592                              &Perl_pp_i_modulo_1;
2593                     /* Make certain we work right this time, too. */
2594                     right = PERL_ABS(right);
2595                }
2596           }
2597 #endif
2598           SETi( left % right );
2599           RETURN;
2600      }
2601 }
2602
2603 PP(pp_i_add)
2604 {
2605     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2606     {
2607       dPOPTOPiirl_ul;
2608       SETi( left + right );
2609       RETURN;
2610     }
2611 }
2612
2613 PP(pp_i_subtract)
2614 {
2615     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2616     {
2617       dPOPTOPiirl_ul;
2618       SETi( left - right );
2619       RETURN;
2620     }
2621 }
2622
2623 PP(pp_i_lt)
2624 {
2625     dSP; tryAMAGICbinSET(lt,0);
2626     {
2627       dPOPTOPiirl;
2628       SETs(boolSV(left < right));
2629       RETURN;
2630     }
2631 }
2632
2633 PP(pp_i_gt)
2634 {
2635     dSP; tryAMAGICbinSET(gt,0);
2636     {
2637       dPOPTOPiirl;
2638       SETs(boolSV(left > right));
2639       RETURN;
2640     }
2641 }
2642
2643 PP(pp_i_le)
2644 {
2645     dSP; tryAMAGICbinSET(le,0);
2646     {
2647       dPOPTOPiirl;
2648       SETs(boolSV(left <= right));
2649       RETURN;
2650     }
2651 }
2652
2653 PP(pp_i_ge)
2654 {
2655     dSP; tryAMAGICbinSET(ge,0);
2656     {
2657       dPOPTOPiirl;
2658       SETs(boolSV(left >= right));
2659       RETURN;
2660     }
2661 }
2662
2663 PP(pp_i_eq)
2664 {
2665     dSP; tryAMAGICbinSET(eq,0);
2666     {
2667       dPOPTOPiirl;
2668       SETs(boolSV(left == right));
2669       RETURN;
2670     }
2671 }
2672
2673 PP(pp_i_ne)
2674 {
2675     dSP; tryAMAGICbinSET(ne,0);
2676     {
2677       dPOPTOPiirl;
2678       SETs(boolSV(left != right));
2679       RETURN;
2680     }
2681 }
2682
2683 PP(pp_i_ncmp)
2684 {
2685     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2686     {
2687       dPOPTOPiirl;
2688       I32 value;
2689
2690       if (left > right)
2691         value = 1;
2692       else if (left < right)
2693         value = -1;
2694       else
2695         value = 0;
2696       SETi(value);
2697       RETURN;
2698     }
2699 }
2700
2701 PP(pp_i_negate)
2702 {
2703     dSP; dTARGET; tryAMAGICun(neg);
2704     SETi(-TOPi);
2705     RETURN;
2706 }
2707
2708 /* High falutin' math. */
2709
2710 PP(pp_atan2)
2711 {
2712     dSP; dTARGET; tryAMAGICbin(atan2,0);
2713     {
2714       dPOPTOPnnrl;
2715       SETn(Perl_atan2(left, right));
2716       RETURN;
2717     }
2718 }
2719
2720 PP(pp_sin)
2721 {
2722     dSP; dTARGET; tryAMAGICun(sin);
2723     {
2724       NV value;
2725       value = POPn;
2726       value = Perl_sin(value);
2727       XPUSHn(value);
2728       RETURN;
2729     }
2730 }
2731
2732 PP(pp_cos)
2733 {
2734     dSP; dTARGET; tryAMAGICun(cos);
2735     {
2736       NV value;
2737       value = POPn;
2738       value = Perl_cos(value);
2739       XPUSHn(value);
2740       RETURN;
2741     }
2742 }
2743
2744 /* Support Configure command-line overrides for rand() functions.
2745    After 5.005, perhaps we should replace this by Configure support
2746    for drand48(), random(), or rand().  For 5.005, though, maintain
2747    compatibility by calling rand() but allow the user to override it.
2748    See INSTALL for details.  --Andy Dougherty  15 July 1998
2749 */
2750 /* Now it's after 5.005, and Configure supports drand48() and random(),
2751    in addition to rand().  So the overrides should not be needed any more.
2752    --Jarkko Hietaniemi  27 September 1998
2753  */
2754
2755 #ifndef HAS_DRAND48_PROTO
2756 extern double drand48 (void);
2757 #endif
2758
2759 PP(pp_rand)
2760 {
2761     dSP; dTARGET;
2762     NV value;
2763     if (MAXARG < 1)
2764         value = 1.0;
2765     else
2766         value = POPn;
2767     if (value == 0.0)
2768         value = 1.0;
2769     if (!PL_srand_called) {
2770         (void)seedDrand01((Rand_seed_t)seed());
2771         PL_srand_called = TRUE;
2772     }
2773     value *= Drand01();
2774     XPUSHn(value);
2775     RETURN;
2776 }
2777
2778 PP(pp_srand)
2779 {
2780     dSP;
2781     UV anum;
2782     if (MAXARG < 1)
2783         anum = seed();
2784     else
2785         anum = POPu;
2786     (void)seedDrand01((Rand_seed_t)anum);
2787     PL_srand_called = TRUE;
2788     EXTEND(SP, 1);
2789     RETPUSHYES;
2790 }
2791
2792 PP(pp_exp)
2793 {
2794     dSP; dTARGET; tryAMAGICun(exp);
2795     {
2796       NV value;
2797       value = POPn;
2798       value = Perl_exp(value);
2799       XPUSHn(value);
2800       RETURN;
2801     }
2802 }
2803
2804 PP(pp_log)
2805 {
2806     dSP; dTARGET; tryAMAGICun(log);
2807     {
2808       NV value;
2809       value = POPn;
2810       if (value <= 0.0) {
2811         SET_NUMERIC_STANDARD();
2812         DIE(aTHX_ "Can't take log of %"NVgf, value);
2813       }
2814       value = Perl_log(value);
2815       XPUSHn(value);
2816       RETURN;
2817     }
2818 }
2819
2820 PP(pp_sqrt)
2821 {
2822     dSP; dTARGET; tryAMAGICun(sqrt);
2823     {
2824       NV value;
2825       value = POPn;
2826       if (value < 0.0) {
2827         SET_NUMERIC_STANDARD();
2828         DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2829       }
2830       value = Perl_sqrt(value);
2831       XPUSHn(value);
2832       RETURN;
2833     }
2834 }
2835
2836 PP(pp_int)
2837 {
2838     dSP; dTARGET; tryAMAGICun(int);
2839     {
2840       NV value;
2841       IV iv = TOPi; /* attempt to convert to IV if possible. */
2842       /* XXX it's arguable that compiler casting to IV might be subtly
2843          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2844          else preferring IV has introduced a subtle behaviour change bug. OTOH
2845          relying on floating point to be accurate is a bug.  */
2846
2847       if (!SvOK(TOPs))
2848         SETu(0);
2849       else if (SvIOK(TOPs)) {
2850         if (SvIsUV(TOPs)) {
2851             UV uv = TOPu;
2852             SETu(uv);
2853         } else
2854             SETi(iv);
2855       } else {
2856           value = TOPn;
2857           if (value >= 0.0) {
2858               if (value < (NV)UV_MAX + 0.5) {
2859                   SETu(U_V(value));
2860               } else {
2861                   SETn(Perl_floor(value));
2862               }
2863           }
2864           else {
2865               if (value > (NV)IV_MIN - 0.5) {
2866                   SETi(I_V(value));
2867               } else {
2868                   SETn(Perl_ceil(value));
2869               }
2870           }
2871       }
2872     }
2873     RETURN;
2874 }
2875
2876 PP(pp_abs)
2877 {
2878     dSP; dTARGET; tryAMAGICun(abs);
2879     {
2880       /* This will cache the NV value if string isn't actually integer  */
2881       IV iv = TOPi;
2882
2883       if (!SvOK(TOPs))
2884         SETu(0);
2885       else if (SvIOK(TOPs)) {
2886         /* IVX is precise  */
2887         if (SvIsUV(TOPs)) {
2888           SETu(TOPu);   /* force it to be numeric only */
2889         } else {
2890           if (iv >= 0) {
2891             SETi(iv);
2892           } else {
2893             if (iv != IV_MIN) {
2894               SETi(-iv);
2895             } else {
2896               /* 2s complement assumption. Also, not really needed as
2897                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2898               SETu(IV_MIN);
2899             }
2900           }
2901         }
2902       } else{
2903         NV value = TOPn;
2904         if (value < 0.0)
2905           value = -value;
2906         SETn(value);
2907       }
2908     }
2909     RETURN;
2910 }
2911
2912
2913 PP(pp_hex)
2914 {
2915     dSP; dTARGET;
2916     char *tmps;
2917     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2918     STRLEN len;
2919     NV result_nv;
2920     UV result_uv;
2921     SV* sv = POPs;
2922
2923     tmps = (SvPVx(sv, len));
2924     if (DO_UTF8(sv)) {
2925          /* If Unicode, try to downgrade
2926           * If not possible, croak. */
2927          SV* tsv = sv_2mortal(newSVsv(sv));
2928
2929          SvUTF8_on(tsv);
2930          sv_utf8_downgrade(tsv, FALSE);
2931          tmps = SvPVX(tsv);
2932     }
2933     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2934     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2935         XPUSHn(result_nv);
2936     }
2937     else {
2938         XPUSHu(result_uv);
2939     }
2940     RETURN;
2941 }
2942
2943 PP(pp_oct)
2944 {
2945     dSP; dTARGET;
2946     char *tmps;
2947     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2948     STRLEN len;
2949     NV result_nv;
2950     UV result_uv;
2951     SV* sv = POPs;
2952
2953     tmps = (SvPVx(sv, len));
2954     if (DO_UTF8(sv)) {
2955          /* If Unicode, try to downgrade
2956           * If not possible, croak. */
2957          SV* tsv = sv_2mortal(newSVsv(sv));
2958
2959          SvUTF8_on(tsv);
2960          sv_utf8_downgrade(tsv, FALSE);
2961          tmps = SvPVX(tsv);
2962     }
2963     while (*tmps && len && isSPACE(*tmps))
2964         tmps++, len--;
2965     if (*tmps == '0')
2966         tmps++, len--;
2967     if (*tmps == 'x')
2968         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2969     else if (*tmps == 'b')
2970         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2971     else
2972         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2973
2974     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2975         XPUSHn(result_nv);
2976     }
2977     else {
2978         XPUSHu(result_uv);
2979     }
2980     RETURN;
2981 }
2982
2983 /* String stuff. */
2984
2985 PP(pp_length)
2986 {
2987     dSP; dTARGET;
2988     SV *sv = TOPs;
2989
2990     if (DO_UTF8(sv))
2991         SETi(sv_len_utf8(sv));
2992     else
2993         SETi(sv_len(sv));
2994     RETURN;
2995 }
2996
2997 PP(pp_substr)
2998 {
2999     dSP; dTARGET;
3000     SV *sv;
3001     I32 len = 0;
3002     STRLEN curlen;
3003     STRLEN utf8_curlen;
3004     I32 pos;
3005     I32 rem;
3006     I32 fail;
3007     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3008     char *tmps;
3009     I32 arybase = PL_curcop->cop_arybase;
3010     SV *repl_sv = NULL;
3011     char *repl = 0;
3012     STRLEN repl_len;
3013     int num_args = PL_op->op_private & 7;
3014     bool repl_need_utf8_upgrade = FALSE;
3015     bool repl_is_utf8 = FALSE;
3016
3017     SvTAINTED_off(TARG);                        /* decontaminate */
3018     SvUTF8_off(TARG);                           /* decontaminate */
3019     if (num_args > 2) {
3020         if (num_args > 3) {
3021             repl_sv = POPs;
3022             repl = SvPV(repl_sv, repl_len);
3023             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3024         }
3025         len = POPi;
3026     }
3027     pos = POPi;
3028     sv = POPs;
3029     PUTBACK;
3030     if (repl_sv) {
3031         if (repl_is_utf8) {
3032             if (!DO_UTF8(sv))
3033                 sv_utf8_upgrade(sv);
3034         }
3035         else if (DO_UTF8(sv))
3036             repl_need_utf8_upgrade = TRUE;
3037     }
3038     tmps = SvPV(sv, curlen);
3039     if (DO_UTF8(sv)) {
3040         utf8_curlen = sv_len_utf8(sv);
3041         if (utf8_curlen == curlen)
3042             utf8_curlen = 0;
3043         else
3044             curlen = utf8_curlen;
3045     }
3046     else
3047         utf8_curlen = 0;
3048
3049     if (pos >= arybase) {
3050         pos -= arybase;
3051         rem = curlen-pos;
3052         fail = rem;
3053         if (num_args > 2) {
3054             if (len < 0) {
3055                 rem += len;
3056                 if (rem < 0)
3057                     rem = 0;
3058             }
3059             else if (rem > len)
3060                      rem = len;
3061         }
3062     }
3063     else {
3064         pos += curlen;
3065         if (num_args < 3)
3066             rem = curlen;
3067         else if (len >= 0) {
3068             rem = pos+len;
3069             if (rem > (I32)curlen)
3070                 rem = curlen;
3071         }
3072         else {
3073             rem = curlen+len;
3074             if (rem < pos)
3075                 rem = pos;
3076         }
3077         if (pos < 0)
3078             pos = 0;
3079         fail = rem;
3080         rem -= pos;
3081     }
3082     if (fail < 0) {
3083         if (lvalue || repl)
3084             Perl_croak(aTHX_ "substr outside of string");
3085         if (ckWARN(WARN_SUBSTR))
3086             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3087         RETPUSHUNDEF;
3088     }
3089     else {
3090         I32 upos = pos;
3091         I32 urem = rem;
3092         if (utf8_curlen)
3093             sv_pos_u2b(sv, &pos, &rem);
3094         tmps += pos;
3095         /* we either return a PV or an LV. If the TARG hasn't been used
3096          * before, or is of that type, reuse it; otherwise use a mortal
3097          * instead. Note that LVs can have an extended lifetime, so also
3098          * dont reuse if refcount > 1 (bug #20933) */
3099         if (SvTYPE(TARG) > SVt_NULL) {
3100             if ( (SvTYPE(TARG) == SVt_PVLV)
3101                     ? (!lvalue || SvREFCNT(TARG) > 1)
3102                     : lvalue)
3103             {
3104                 TARG = sv_newmortal();
3105             }
3106         }
3107
3108         sv_setpvn(TARG, tmps, rem);
3109 #ifdef USE_LOCALE_COLLATE
3110         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3111 #endif
3112         if (utf8_curlen)
3113             SvUTF8_on(TARG);
3114         if (repl) {
3115             SV* repl_sv_copy = NULL;
3116
3117             if (repl_need_utf8_upgrade) {
3118                 repl_sv_copy = newSVsv(repl_sv);
3119                 sv_utf8_upgrade(repl_sv_copy);
3120                 repl = SvPV(repl_sv_copy, repl_len);
3121                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3122             }
3123             sv_insert(sv, pos, rem, repl, repl_len);
3124             if (repl_is_utf8)
3125                 SvUTF8_on(sv);
3126             if (repl_sv_copy)
3127                 SvREFCNT_dec(repl_sv_copy);
3128         }
3129         else if (lvalue) {              /* it's an lvalue! */
3130             if (!SvGMAGICAL(sv)) {
3131                 if (SvROK(sv)) {
3132                     STRLEN n_a;
3133                     SvPV_force(sv,n_a);
3134                     if (ckWARN(WARN_SUBSTR))
3135                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3136                                 "Attempt to use reference as lvalue in substr");
3137                 }
3138                 if (SvOK(sv))           /* is it defined ? */
3139                     (void)SvPOK_only_UTF8(sv);
3140                 else
3141                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3142             }
3143
3144             if (SvTYPE(TARG) < SVt_PVLV) {
3145                 sv_upgrade(TARG, SVt_PVLV);
3146                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3147             }
3148             else
3149                 SvOK_off(TARG);
3150
3151             LvTYPE(TARG) = 'x';
3152             if (LvTARG(TARG) != sv) {
3153                 if (LvTARG(TARG))
3154                     SvREFCNT_dec(LvTARG(TARG));
3155                 LvTARG(TARG) = SvREFCNT_inc(sv);
3156             }
3157             LvTARGOFF(TARG) = upos;
3158             LvTARGLEN(TARG) = urem;
3159         }
3160     }
3161     SPAGAIN;
3162     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3163     RETURN;
3164 }
3165
3166 PP(pp_vec)
3167 {
3168     dSP; dTARGET;
3169     register IV size   = POPi;
3170     register IV offset = POPi;
3171     register SV *src = POPs;
3172     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3173
3174     SvTAINTED_off(TARG);                /* decontaminate */
3175     if (lvalue) {                       /* it's an lvalue! */
3176         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3177             TARG = sv_newmortal();
3178         if (SvTYPE(TARG) < SVt_PVLV) {
3179             sv_upgrade(TARG, SVt_PVLV);
3180             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3181         }
3182         LvTYPE(TARG) = 'v';
3183         if (LvTARG(TARG) != src) {
3184             if (LvTARG(TARG))
3185                 SvREFCNT_dec(LvTARG(TARG));
3186             LvTARG(TARG) = SvREFCNT_inc(src);
3187         }
3188         LvTARGOFF(TARG) = offset;
3189         LvTARGLEN(TARG) = size;
3190     }
3191
3192     sv_setuv(TARG, do_vecget(src, offset, size));
3193     PUSHs(TARG);
3194     RETURN;
3195 }
3196
3197 PP(pp_index)
3198 {
3199     dSP; dTARGET;
3200     SV *big;
3201     SV *little;
3202     I32 offset;
3203     I32 retval;
3204     char *tmps;
3205     char *tmps2;
3206     STRLEN biglen;
3207     I32 arybase = PL_curcop->cop_arybase;
3208
3209     if (MAXARG < 3)
3210         offset = 0;
3211     else
3212         offset = POPi - arybase;
3213     little = POPs;
3214     big = POPs;
3215     tmps = SvPV(big, biglen);
3216     if (offset > 0 && DO_UTF8(big))
3217         sv_pos_u2b(big, &offset, 0);
3218     if (offset < 0)
3219         offset = 0;
3220     else if (offset > (I32)biglen)
3221         offset = biglen;
3222     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3223       (unsigned char*)tmps + biglen, little, 0)))
3224         retval = -1;
3225     else
3226         retval = tmps2 - tmps;
3227     if (retval > 0 && DO_UTF8(big))
3228         sv_pos_b2u(big, &retval);
3229     PUSHi(retval + arybase);
3230     RETURN;
3231 }
3232
3233 PP(pp_rindex)
3234 {
3235     dSP; dTARGET;
3236     SV *big;
3237     SV *little;
3238     STRLEN blen;
3239     STRLEN llen;
3240     I32 offset;
3241     I32 retval;
3242     char *tmps;
3243     char *tmps2;
3244     I32 arybase = PL_curcop->cop_arybase;
3245
3246     if (MAXARG >= 3)
3247         offset = POPi;
3248     little = POPs;
3249     big = POPs;
3250     tmps2 = SvPV(little, llen);
3251     tmps = SvPV(big, blen);
3252     if (MAXARG < 3)
3253         offset = blen;
3254     else {
3255         if (offset > 0 && DO_UTF8(big))
3256             sv_pos_u2b(big, &offset, 0);
3257         offset = offset - arybase + llen;
3258     }
3259     if (offset < 0)
3260         offset = 0;
3261     else if (offset > (I32)blen)
3262         offset = blen;
3263     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3264                           tmps2, tmps2 + llen)))
3265         retval = -1;
3266     else
3267         retval = tmps2 - tmps;
3268     if (retval > 0 && DO_UTF8(big))
3269         sv_pos_b2u(big, &retval);
3270     PUSHi(retval + arybase);
3271     RETURN;
3272 }
3273
3274 PP(pp_sprintf)
3275 {
3276     dSP; dMARK; dORIGMARK; dTARGET;
3277     do_sprintf(TARG, SP-MARK, MARK+1);
3278     TAINT_IF(SvTAINTED(TARG));
3279     if (DO_UTF8(*(MARK+1)))
3280         SvUTF8_on(TARG);
3281     SP = ORIGMARK;
3282     PUSHTARG;
3283     RETURN;
3284 }
3285
3286 PP(pp_ord)
3287 {
3288     dSP; dTARGET;
3289     SV *argsv = POPs;
3290     STRLEN len;
3291     U8 *s = (U8*)SvPVx(argsv, len);
3292     SV *tmpsv;
3293
3294     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3295         tmpsv = sv_2mortal(newSVsv(argsv));
3296         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3297         argsv = tmpsv;
3298     }
3299
3300     XPUSHu(DO_UTF8(argsv) ?
3301            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3302            (*s & 0xff));
3303
3304     RETURN;
3305 }
3306
3307 PP(pp_chr)
3308 {
3309     dSP; dTARGET;
3310     char *tmps;
3311     UV value = POPu;
3312
3313     (void)SvUPGRADE(TARG,SVt_PV);
3314
3315     if (value > 255 && !IN_BYTES) {
3316         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3317         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3318         SvCUR_set(TARG, tmps - SvPVX(TARG));
3319         *tmps = '\0';
3320         (void)SvPOK_only(TARG);
3321         SvUTF8_on(TARG);
3322         XPUSHs(TARG);
3323         RETURN;
3324     }
3325
3326     SvGROW(TARG,2);
3327     SvCUR_set(TARG, 1);
3328     tmps = SvPVX(TARG);
3329     *tmps++ = (char)value;
3330     *tmps = '\0';
3331     (void)SvPOK_only(TARG);
3332     if (PL_encoding && !IN_BYTES) {
3333         sv_recode_to_utf8(TARG, PL_encoding);
3334         tmps = SvPVX(TARG);
3335         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3336             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3337             SvGROW(TARG, 3);
3338             tmps = SvPVX(TARG);
3339             SvCUR_set(TARG, 2);
3340             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3341             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3342             *tmps = '\0';
3343             SvUTF8_on(TARG);
3344         }
3345     }
3346     XPUSHs(TARG);
3347     RETURN;
3348 }
3349
3350 PP(pp_crypt)
3351 {
3352     dSP; dTARGET;
3353 #ifdef HAS_CRYPT
3354     dPOPTOPssrl;
3355     STRLEN n_a;
3356     STRLEN len;
3357     char *tmps = SvPV(left, len);
3358
3359     if (DO_UTF8(left)) {
3360          /* If Unicode, try to downgrade.
3361           * If not possible, croak.
3362           * Yes, we made this up.  */
3363          SV* tsv = sv_2mortal(newSVsv(left));
3364
3365          SvUTF8_on(tsv);
3366          sv_utf8_downgrade(tsv, FALSE);
3367          tmps = SvPVX(tsv);
3368     }
3369 #   ifdef USE_ITHREADS
3370 #     ifdef HAS_CRYPT_R
3371     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3372       /* This should be threadsafe because in ithreads there is only
3373        * one thread per interpreter.  If this would not be true,
3374        * we would need a mutex to protect this malloc. */
3375         PL_reentrant_buffer->_crypt_struct_buffer =
3376           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3377 #if defined(__GLIBC__) || defined(__EMX__)
3378         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3379             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3380             /* work around glibc-2.2.5 bug */
3381             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3382         }
3383 #endif
3384     }
3385 #     endif /* HAS_CRYPT_R */
3386 #   endif /* USE_ITHREADS */
3387 #   ifdef FCRYPT
3388     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3389 #   else
3390     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3391 #   endif
3392     SETs(TARG);
3393     RETURN;
3394 #else
3395     DIE(aTHX_
3396       "The crypt() function is unimplemented due to excessive paranoia.");
3397 #endif
3398 }
3399
3400 PP(pp_ucfirst)
3401 {
3402     dSP;
3403     SV *sv = TOPs;
3404     register U8 *s;
3405     STRLEN slen;
3406
3407     SvGETMAGIC(sv);
3408     if (DO_UTF8(sv) &&
3409         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3410         UTF8_IS_START(*s)) {
3411         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3412         STRLEN ulen;
3413         STRLEN tculen;
3414
3415         utf8_to_uvchr(s, &ulen);
3416         toTITLE_utf8(s, tmpbuf, &tculen);
3417         utf8_to_uvchr(tmpbuf, 0);
3418
3419         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3420             dTARGET;
3421             /* slen is the byte length of the whole SV.
3422              * ulen is the byte length of the original Unicode character
3423              * stored as UTF-8 at s.
3424              * tculen is the byte length of the freshly titlecased
3425              * Unicode character stored as UTF-8 at tmpbuf.
3426              * We first set the result to be the titlecased character,
3427              * and then append the rest of the SV data. */
3428             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3429             if (slen > ulen)
3430                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3431             SvUTF8_on(TARG);
3432             SETs(TARG);
3433         }
3434         else {
3435             s = (U8*)SvPV_force_nomg(sv, slen);
3436             Copy(tmpbuf, s, tculen, U8);
3437         }
3438     }
3439     else {
3440         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3441             dTARGET;
3442             SvUTF8_off(TARG);                           /* decontaminate */
3443             sv_setsv_nomg(TARG, sv);
3444             sv = TARG;
3445             SETs(sv);
3446         }
3447         s = (U8*)SvPV_force_nomg(sv, slen);
3448         if (*s) {
3449             if (IN_LOCALE_RUNTIME) {
3450                 TAINT;
3451                 SvTAINTED_on(sv);
3452                 *s = toUPPER_LC(*s);
3453             }
3454             else
3455                 *s = toUPPER(*s);
3456         }
3457     }
3458     SvSETMAGIC(sv);
3459     RETURN;
3460 }
3461
3462 PP(pp_lcfirst)
3463 {
3464     dSP;
3465     SV *sv = TOPs;
3466     register U8 *s;
3467     STRLEN slen;
3468
3469     SvGETMAGIC(sv);
3470     if (DO_UTF8(sv) &&
3471         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3472         UTF8_IS_START(*s)) {
3473         STRLEN ulen;
3474         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3475         U8 *tend;
3476         UV uv;
3477
3478         toLOWER_utf8(s, tmpbuf, &ulen);
3479         uv = utf8_to_uvchr(tmpbuf, 0);
3480         tend = uvchr_to_utf8(tmpbuf, uv);
3481
3482         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3483             dTARGET;
3484             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3485             if (slen > ulen)
3486                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3487             SvUTF8_on(TARG);
3488             SETs(TARG);
3489         }
3490         else {
3491             s = (U8*)SvPV_force_nomg(sv, slen);
3492             Copy(tmpbuf, s, ulen, U8);
3493         }
3494     }
3495     else {
3496         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3497             dTARGET;
3498             SvUTF8_off(TARG);                           /* decontaminate */
3499             sv_setsv_nomg(TARG, sv);
3500             sv = TARG;
3501             SETs(sv);
3502         }
3503         s = (U8*)SvPV_force_nomg(sv, slen);
3504         if (*s) {
3505             if (IN_LOCALE_RUNTIME) {
3506                 TAINT;
3507                 SvTAINTED_on(sv);
3508                 *s = toLOWER_LC(*s);
3509             }
3510             else
3511                 *s = toLOWER(*s);
3512         }
3513     }
3514     SvSETMAGIC(sv);
3515     RETURN;
3516 }
3517
3518 PP(pp_uc)
3519 {
3520     dSP;
3521     SV *sv = TOPs;
3522     register U8 *s;
3523     STRLEN len;
3524
3525     SvGETMAGIC(sv);
3526     if (DO_UTF8(sv)) {
3527         dTARGET;
3528         STRLEN ulen;
3529         register U8 *d;
3530         U8 *send;
3531         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3532
3533         s = (U8*)SvPV_nomg(sv,len);
3534         if (!len) {
3535             SvUTF8_off(TARG);                           /* decontaminate */
3536             sv_setpvn(TARG, "", 0);
3537             SETs(TARG);
3538         }
3539         else {
3540             STRLEN nchar = utf8_length(s, s + len);
3541
3542             (void)SvUPGRADE(TARG, SVt_PV);
3543             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3544             (void)SvPOK_only(TARG);
3545             d = (U8*)SvPVX(TARG);
3546             send = s + len;
3547             while (s < send) {
3548                 toUPPER_utf8(s, tmpbuf, &ulen);
3549                 Copy(tmpbuf, d, ulen, U8);
3550                 d += ulen;
3551                 s += UTF8SKIP(s);
3552             }
3553             *d = '\0';
3554             SvUTF8_on(TARG);
3555             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3556             SETs(TARG);
3557         }
3558     }
3559     else {
3560         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3561             dTARGET;
3562             SvUTF8_off(TARG);                           /* decontaminate */
3563             sv_setsv_nomg(TARG, sv);
3564             sv = TARG;
3565             SETs(sv);
3566         }
3567         s = (U8*)SvPV_force_nomg(sv, len);
3568         if (len) {
3569             register U8 *send = s + len;
3570
3571             if (IN_LOCALE_RUNTIME) {
3572                 TAINT;
3573                 SvTAINTED_on(sv);
3574                 for (; s < send; s++)
3575                     *s = toUPPER_LC(*s);
3576             }
3577             else {
3578                 for (; s < send; s++)
3579                     *s = toUPPER(*s);
3580             }
3581         }
3582     }
3583     SvSETMAGIC(sv);
3584     RETURN;
3585 }
3586
3587 PP(pp_lc)
3588 {
3589     dSP;
3590     SV *sv = TOPs;
3591     register U8 *s;
3592     STRLEN len;
3593
3594     SvGETMAGIC(sv);
3595     if (DO_UTF8(sv)) {
3596         dTARGET;
3597         STRLEN ulen;
3598         register U8 *d;
3599         U8 *send;
3600         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3601
3602         s = (U8*)SvPV_nomg(sv,len);
3603         if (!len) {
3604             SvUTF8_off(TARG);                           /* decontaminate */
3605             sv_setpvn(TARG, "", 0);
3606             SETs(TARG);
3607         }
3608         else {
3609             STRLEN nchar = utf8_length(s, s + len);
3610
3611             (void)SvUPGRADE(TARG, SVt_PV);
3612             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3613             (void)SvPOK_only(TARG);
3614             d = (U8*)SvPVX(TARG);
3615             send = s + len;
3616             while (s < send) {
3617                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3618 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3619                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3620                      /*
3621                       * Now if the sigma is NOT followed by
3622                       * /$ignorable_sequence$cased_letter/;
3623                       * and it IS preceded by
3624                       * /$cased_letter$ignorable_sequence/;
3625                       * where $ignorable_sequence is
3626                       * [\x{2010}\x{AD}\p{Mn}]*
3627                       * and $cased_letter is
3628                       * [\p{Ll}\p{Lo}\p{Lt}]
3629                       * then it should be mapped to 0x03C2,
3630                       * (GREEK SMALL LETTER FINAL SIGMA),
3631                       * instead of staying 0x03A3.
3632                       * See lib/unicore/SpecCase.txt.
3633                       */
3634                 }
3635                 Copy(tmpbuf, d, ulen, U8);
3636                 d += ulen;
3637                 s += UTF8SKIP(s);
3638             }
3639             *d = '\0';
3640             SvUTF8_on(TARG);
3641             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3642             SETs(TARG);
3643         }
3644     }
3645     else {
3646         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3647             dTARGET;
3648             SvUTF8_off(TARG);                           /* decontaminate */
3649             sv_setsv_nomg(TARG, sv);
3650             sv = TARG;
3651             SETs(sv);
3652         }
3653
3654         s = (U8*)SvPV_force_nomg(sv, len);
3655         if (len) {
3656             register U8 *send = s + len;
3657
3658             if (IN_LOCALE_RUNTIME) {
3659                 TAINT;
3660                 SvTAINTED_on(sv);
3661                 for (; s < send; s++)
3662                     *s = toLOWER_LC(*s);
3663             }
3664             else {
3665                 for (; s < send; s++)
3666                     *s = toLOWER(*s);
3667             }
3668         }
3669     }
3670     SvSETMAGIC(sv);
3671     RETURN;
3672 }
3673
3674 PP(pp_quotemeta)
3675 {
3676     dSP; dTARGET;
3677     SV *sv = TOPs;
3678     STRLEN len;
3679     register char *s = SvPV(sv,len);
3680     register char *d;
3681
3682     SvUTF8_off(TARG);                           /* decontaminate */
3683     if (len) {
3684         (void)SvUPGRADE(TARG, SVt_PV);
3685         SvGROW(TARG, (len * 2) + 1);
3686         d = SvPVX(TARG);
3687         if (DO_UTF8(sv)) {
3688             while (len) {
3689                 if (UTF8_IS_CONTINUED(*s)) {
3690                     STRLEN ulen = UTF8SKIP(s);
3691                     if (ulen > len)
3692                         ulen = len;
3693                     len -= ulen;
3694                     while (ulen--)
3695                         *d++ = *s++;
3696                 }
3697                 else {
3698                     if (!isALNUM(*s))
3699                         *d++ = '\\';
3700                     *d++ = *s++;
3701                     len--;
3702                 }
3703             }
3704             SvUTF8_on(TARG);
3705         }
3706         else {
3707             while (len--) {
3708                 if (!isALNUM(*s))
3709                     *d++ = '\\';
3710                 *d++ = *s++;
3711             }
3712         }
3713         *d = '\0';
3714         SvCUR_set(TARG, d - SvPVX(TARG));
3715         (void)SvPOK_only_UTF8(TARG);
3716     }
3717     else
3718         sv_setpvn(TARG, s, len);
3719     SETs(TARG);
3720     if (SvSMAGICAL(TARG))
3721         mg_set(TARG);
3722     RETURN;
3723 }
3724
3725 /* Arrays. */
3726
3727 PP(pp_aslice)
3728 {
3729     dSP; dMARK; dORIGMARK;
3730     register SV** svp;
3731     register AV* av = (AV*)POPs;
3732     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3733     I32 arybase = PL_curcop->cop_arybase;
3734     I32 elem;
3735
3736     if (SvTYPE(av) == SVt_PVAV) {
3737         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3738             I32 max = -1;
3739             for (svp = MARK + 1; svp <= SP; svp++) {
3740                 elem = SvIVx(*svp);
3741                 if (elem > max)
3742                     max = elem;
3743             }
3744             if (max > AvMAX(av))
3745                 av_extend(av, max);
3746         }
3747         while (++MARK <= SP) {
3748             elem = SvIVx(*MARK);
3749
3750             if (elem > 0)
3751                 elem -= arybase;
3752             svp = av_fetch(av, elem, lval);
3753             if (lval) {
3754                 if (!svp || *svp == &PL_sv_undef)
3755                     DIE(aTHX_ PL_no_aelem, elem);
3756                 if (PL_op->op_private & OPpLVAL_INTRO)
3757                     save_aelem(av, elem, svp);
3758             }
3759             *MARK = svp ? *svp : &PL_sv_undef;
3760         }
3761     }
3762     if (GIMME != G_ARRAY) {
3763         MARK = ORIGMARK;
3764         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3765         SP = MARK;
3766     }
3767     RETURN;
3768 }
3769
3770 /* Associative arrays. */
3771
3772 PP(pp_each)
3773 {
3774     dSP;
3775     HV *hash = (HV*)POPs;
3776     HE *entry;
3777     I32 gimme = GIMME_V;
3778
3779     PUTBACK;
3780     /* might clobber stack_sp */
3781     entry = hv_iternext(hash);
3782     SPAGAIN;
3783
3784     EXTEND(SP, 2);
3785     if (entry) {
3786         SV* sv = hv_iterkeysv(entry);
3787         PUSHs(sv);      /* won't clobber stack_sp */
3788         if (gimme == G_ARRAY) {
3789             SV *val;
3790             PUTBACK;
3791             /* might clobber stack_sp */
3792             val = hv_iterval(hash, entry);
3793             SPAGAIN;
3794             PUSHs(val);
3795         }
3796     }
3797     else if (gimme == G_SCALAR)
3798         RETPUSHUNDEF;
3799
3800     RETURN;
3801 }
3802
3803 PP(pp_values)
3804 {
3805     return do_kv();
3806 }
3807
3808 PP(pp_keys)
3809 {
3810     return do_kv();
3811 }
3812
3813 PP(pp_delete)
3814 {
3815     dSP;
3816     I32 gimme = GIMME_V;
3817     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3818     SV *sv;
3819     HV *hv;
3820
3821     if (PL_op->op_private & OPpSLICE) {
3822         dMARK; dORIGMARK;
3823         U32 hvtype;
3824         hv = (HV*)POPs;
3825         hvtype = SvTYPE(hv);
3826         if (hvtype == SVt_PVHV) {                       /* hash element */
3827             while (++MARK <= SP) {
3828                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3829                 *MARK = sv ? sv : &PL_sv_undef;
3830             }
3831         }
3832         else if (hvtype == SVt_PVAV) {                  /* array element */
3833             if (PL_op->op_flags & OPf_SPECIAL) {
3834                 while (++MARK <= SP) {
3835                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3836                     *MARK = sv ? sv : &PL_sv_undef;
3837                 }
3838             }
3839         }
3840         else
3841             DIE(aTHX_ "Not a HASH reference");
3842         if (discard)
3843             SP = ORIGMARK;
3844         else if (gimme == G_SCALAR) {
3845             MARK = ORIGMARK;
3846             if (SP > MARK)
3847                 *++MARK = *SP;
3848             else
3849                 *++MARK = &PL_sv_undef;
3850             SP = MARK;
3851         }
3852     }
3853     else {
3854         SV *keysv = POPs;
3855         hv = (HV*)POPs;
3856         if (SvTYPE(hv) == SVt_PVHV)
3857             sv = hv_delete_ent(hv, keysv, discard, 0);
3858         else if (SvTYPE(hv) == SVt_PVAV) {
3859             if (PL_op->op_flags & OPf_SPECIAL)
3860                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3861             else
3862                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3863         }
3864         else
3865             DIE(aTHX_ "Not a HASH reference");
3866         if (!sv)
3867             sv = &PL_sv_undef;
3868         if (!discard)
3869             PUSHs(sv);
3870     }
3871     RETURN;
3872 }
3873
3874 PP(pp_exists)
3875 {
3876     dSP;
3877     SV *tmpsv;
3878     HV *hv;
3879
3880     if (PL_op->op_private & OPpEXISTS_SUB) {
3881         GV *gv;
3882         CV *cv;
3883         SV *sv = POPs;
3884         cv = sv_2cv(sv, &hv, &gv, FALSE);
3885         if (cv)
3886             RETPUSHYES;
3887         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3888             RETPUSHYES;
3889         RETPUSHNO;
3890     }
3891     tmpsv = POPs;
3892     hv = (HV*)POPs;
3893     if (SvTYPE(hv) == SVt_PVHV) {
3894         if (hv_exists_ent(hv, tmpsv, 0))
3895             RETPUSHYES;
3896     }
3897     else if (SvTYPE(hv) == SVt_PVAV) {
3898         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3899             if (av_exists((AV*)hv, SvIV(tmpsv)))
3900                 RETPUSHYES;
3901         }
3902     }
3903     else {
3904         DIE(aTHX_ "Not a HASH reference");
3905     }
3906     RETPUSHNO;
3907 }
3908
3909 PP(pp_hslice)
3910 {
3911     dSP; dMARK; dORIGMARK;
3912     register HV *hv = (HV*)POPs;
3913     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3914     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3915     bool other_magic = FALSE;
3916
3917     if (localizing) {
3918         MAGIC *mg;
3919         HV *stash;
3920
3921         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3922             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3923              /* Try to preserve the existenceness of a tied hash
3924               * element by using EXISTS and DELETE if possible.
3925               * Fallback to FETCH and STORE otherwise */
3926              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3927              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3928              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3929     }
3930
3931     while (++MARK <= SP) {
3932         SV *keysv = *MARK;
3933         SV **svp;
3934         HE *he;
3935         bool preeminent = FALSE;
3936
3937         if (localizing) {
3938             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3939                 hv_exists_ent(hv, keysv, 0);
3940         }
3941
3942         he = hv_fetch_ent(hv, keysv, lval, 0);
3943         svp = he ? &HeVAL(he) : 0;
3944
3945         if (lval) {
3946             if (!svp || *svp == &PL_sv_undef) {
3947                 STRLEN n_a;
3948                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3949             }
3950             if (localizing) {
3951                 if (preeminent)
3952                     save_helem(hv, keysv, svp);
3953                 else {
3954                     STRLEN keylen;
3955                     char *key = SvPV(keysv, keylen);
3956                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3957                 }
3958             }
3959         }
3960         *MARK = svp ? *svp : &PL_sv_undef;
3961     }
3962     if (GIMME != G_ARRAY) {
3963         MARK = ORIGMARK;
3964         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3965         SP = MARK;
3966     }
3967     RETURN;
3968 }
3969
3970 /* List operators. */
3971
3972 PP(pp_list)
3973 {
3974     dSP; dMARK;
3975     if (GIMME != G_ARRAY) {
3976         if (++MARK <= SP)
3977             *MARK = *SP;                /* unwanted list, return last item */
3978         else
3979             *MARK = &PL_sv_undef;
3980         SP = MARK;
3981     }
3982     RETURN;
3983 }
3984
3985 PP(pp_lslice)
3986 {
3987     dSP;
3988     SV **lastrelem = PL_stack_sp;
3989     SV **lastlelem = PL_stack_base + POPMARK;
3990     SV **firstlelem = PL_stack_base + POPMARK + 1;
3991     register SV **firstrelem = lastlelem + 1;
3992     I32 arybase = PL_curcop->cop_arybase;
3993     I32 lval = PL_op->op_flags & OPf_MOD;
3994     I32 is_something_there = lval;
3995
3996     register I32 max = lastrelem - lastlelem;
3997     register SV **lelem;
3998     register I32 ix;
3999
4000     if (GIMME != G_ARRAY) {
4001         ix = SvIVx(*lastlelem);
4002         if (ix < 0)
4003             ix += max;
4004         else
4005             ix -= arybase;
4006         if (ix < 0 || ix >= max)
4007             *firstlelem = &PL_sv_undef;
4008         else
4009             *firstlelem = firstrelem[ix];
4010         SP = firstlelem;
4011         RETURN;
4012     }
4013
4014     if (max == 0) {
4015         SP = firstlelem - 1;
4016         RETURN;
4017     }
4018
4019     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4020         ix = SvIVx(*lelem);
4021         if (ix < 0)
4022             ix += max;
4023         else
4024             ix -= arybase;
4025         if (ix < 0 || ix >= max)
4026             *lelem = &PL_sv_undef;
4027         else {
4028             is_something_there = TRUE;
4029             if (!(*lelem = firstrelem[ix]))
4030                 *lelem = &PL_sv_undef;
4031         }
4032     }
4033     if (is_something_there)
4034         SP = lastlelem;
4035     else
4036         SP = firstlelem - 1;
4037     RETURN;
4038 }
4039
4040 PP(pp_anonlist)
4041 {
4042     dSP; dMARK; dORIGMARK;
4043     I32 items = SP - MARK;
4044     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4045     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4046     XPUSHs(av);
4047     RETURN;
4048 }
4049
4050 PP(pp_anonhash)
4051 {
4052     dSP; dMARK; dORIGMARK;
4053     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4054
4055     while (MARK < SP) {
4056         SV* key = *++MARK;
4057         SV *val = NEWSV(46, 0);
4058         if (MARK < SP)
4059             sv_setsv(val, *++MARK);
4060         else if (ckWARN(WARN_MISC))
4061             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4062         (void)hv_store_ent(hv,key,val,0);
4063     }
4064     SP = ORIGMARK;
4065     XPUSHs((SV*)hv);
4066     RETURN;
4067 }
4068
4069 PP(pp_splice)
4070 {
4071     dSP; dMARK; dORIGMARK;
4072     register AV *ary = (AV*)*++MARK;
4073     register SV **src;
4074     register SV **dst;
4075     register I32 i;
4076     register I32 offset;
4077     register I32 length;
4078     I32 newlen;
4079     I32 after;
4080     I32 diff;
4081     SV **tmparyval = 0;
4082     MAGIC *mg;
4083
4084     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4085         *MARK-- = SvTIED_obj((SV*)ary, mg);
4086         PUSHMARK(MARK);
4087         PUTBACK;
4088         ENTER;
4089         call_method("SPLICE",GIMME_V);
4090         LEAVE;
4091         SPAGAIN;
4092         RETURN;
4093     }
4094
4095     SP++;
4096
4097     if (++MARK < SP) {
4098         offset = i = SvIVx(*MARK);
4099         if (offset < 0)
4100             offset += AvFILLp(ary) + 1;
4101         else
4102             offset -= PL_curcop->cop_arybase;
4103         if (offset < 0)
4104             DIE(aTHX_ PL_no_aelem, i);
4105         if (++MARK < SP) {
4106             length = SvIVx(*MARK++);
4107             if (length < 0) {
4108                 length += AvFILLp(ary) - offset + 1;
4109                 if (length < 0)
4110                     length = 0;
4111             }
4112         }
4113         else
4114             length = AvMAX(ary) + 1;            /* close enough to infinity */
4115     }
4116     else {
4117         offset = 0;
4118         length = AvMAX(ary) + 1;
4119     }
4120     if (offset > AvFILLp(ary) + 1) {
4121         if (ckWARN(WARN_MISC))
4122             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4123         offset = AvFILLp(ary) + 1;
4124     }
4125     after = AvFILLp(ary) + 1 - (offset + length);
4126     if (after < 0) {                            /* not that much array */
4127         length += after;                        /* offset+length now in array */
4128         after = 0;
4129         if (!AvALLOC(ary))
4130             av_extend(ary, 0);
4131     }
4132
4133     /* At this point, MARK .. SP-1 is our new LIST */
4134
4135     newlen = SP - MARK;
4136     diff = newlen - length;
4137     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4138         av_reify(ary);
4139
4140     /* make new elements SVs now: avoid problems if they're from the array */
4141     for (dst = MARK, i = newlen; i; i--) {
4142         SV *h = *dst;
4143         *dst = NEWSV(46, 0);
4144         sv_setsv(*dst++, h);
4145     }
4146
4147     if (diff < 0) {                             /* shrinking the area */
4148         if (newlen) {
4149             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4150             Copy(MARK, tmparyval, newlen, SV*);
4151         }
4152
4153         MARK = ORIGMARK + 1;
4154         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4155             MEXTEND(MARK, length);
4156             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4157             if (AvREAL(ary)) {
4158                 EXTEND_MORTAL(length);
4159                 for (i = length, dst = MARK; i; i--) {
4160                     sv_2mortal(*dst);   /* free them eventualy */
4161                     dst++;
4162                 }
4163             }
4164             MARK += length - 1;
4165         }
4166         else {
4167             *MARK = AvARRAY(ary)[offset+length-1];
4168             if (AvREAL(ary)) {
4169                 sv_2mortal(*MARK);
4170                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4171                     SvREFCNT_dec(*dst++);       /* free them now */
4172             }
4173         }
4174         AvFILLp(ary) += diff;
4175
4176         /* pull up or down? */
4177
4178         if (offset < after) {                   /* easier to pull up */
4179             if (offset) {                       /* esp. if nothing to pull */
4180                 src = &AvARRAY(ary)[offset-1];
4181                 dst = src - diff;               /* diff is negative */
4182                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4183                     *dst-- = *src--;
4184             }
4185             dst = AvARRAY(ary);
4186             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4187             AvMAX(ary) += diff;
4188         }
4189         else {
4190             if (after) {                        /* anything to pull down? */
4191                 src = AvARRAY(ary) + offset + length;
4192                 dst = src + diff;               /* diff is negative */
4193                 Move(src, dst, after, SV*);
4194             }
4195             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4196                                                 /* avoid later double free */
4197         }
4198         i = -diff;
4199         while (i)
4200             dst[--i] = &PL_sv_undef;
4201
4202         if (newlen) {
4203             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4204             Safefree(tmparyval);
4205         }
4206     }
4207     else {                                      /* no, expanding (or same) */
4208         if (length) {
4209             New(452, tmparyval, length, SV*);   /* so remember deletion */
4210             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4211         }
4212
4213         if (diff > 0) {                         /* expanding */
4214
4215             /* push up or down? */
4216
4217             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4218                 if (offset) {
4219                     src = AvARRAY(ary);
4220                     dst = src - diff;
4221                     Move(src, dst, offset, SV*);
4222                 }
4223                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4224                 AvMAX(ary) += diff;
4225                 AvFILLp(ary) += diff;
4226             }
4227             else {
4228                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4229                     av_extend(ary, AvFILLp(ary) + diff);
4230                 AvFILLp(ary) += diff;
4231
4232                 if (after) {
4233                     dst = AvARRAY(ary) + AvFILLp(ary);
4234                     src = dst - diff;
4235                     for (i = after; i; i--) {
4236                         *dst-- = *src--;
4237                     }
4238                 }
4239             }
4240         }
4241
4242         if (newlen) {
4243             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4244         }
4245
4246         MARK = ORIGMARK + 1;
4247         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4248             if (length) {
4249                 Copy(tmparyval, MARK, length, SV*);
4250                 if (AvREAL(ary)) {
4251                     EXTEND_MORTAL(length);
4252                     for (i = length, dst = MARK; i; i--) {
4253                         sv_2mortal(*dst);       /* free them eventualy */
4254                         dst++;
4255                     }
4256                 }
4257                 Safefree(tmparyval);
4258             }
4259             MARK += length - 1;
4260         }
4261         else if (length--) {
4262             *MARK = tmparyval[length];
4263             if (AvREAL(ary)) {
4264                 sv_2mortal(*MARK);
4265                 while (length-- > 0)
4266                     SvREFCNT_dec(tmparyval[length]);
4267             }
4268             Safefree(tmparyval);
4269         }
4270         else
4271             *MARK = &PL_sv_undef;
4272     }
4273     SP = MARK;
4274     RETURN;
4275 }
4276
4277 PP(pp_push)
4278 {
4279     dSP; dMARK; dORIGMARK; dTARGET;
4280     register AV *ary = (AV*)*++MARK;
4281     register SV *sv = &PL_sv_undef;
4282     MAGIC *mg;
4283
4284     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4285         *MARK-- = SvTIED_obj((SV*)ary, mg);
4286         PUSHMARK(MARK);
4287         PUTBACK;
4288         ENTER;
4289         call_method("PUSH",G_SCALAR|G_DISCARD);
4290         LEAVE;
4291         SPAGAIN;
4292     }
4293     else {
4294         /* Why no pre-extend of ary here ? */
4295         for (++MARK; MARK <= SP; MARK++) {
4296             sv = NEWSV(51, 0);
4297             if (*MARK)
4298                 sv_setsv(sv, *MARK);
4299             av_push(ary, sv);
4300         }
4301     }
4302     SP = ORIGMARK;
4303     PUSHi( AvFILL(ary) + 1 );
4304     RETURN;
4305 }
4306
4307 PP(pp_pop)
4308 {
4309     dSP;
4310     AV *av = (AV*)POPs;
4311     SV *sv = av_pop(av);
4312     if (AvREAL(av))
4313         (void)sv_2mortal(sv);
4314     PUSHs(sv);
4315     RETURN;
4316 }
4317
4318 PP(pp_shift)
4319 {
4320     dSP;
4321     AV *av = (AV*)POPs;
4322     SV *sv = av_shift(av);
4323     EXTEND(SP, 1);
4324     if (!sv)
4325         RETPUSHUNDEF;
4326     if (AvREAL(av))
4327         (void)sv_2mortal(sv);
4328     PUSHs(sv);
4329     RETURN;
4330 }
4331
4332 PP(pp_unshift)
4333 {
4334     dSP; dMARK; dORIGMARK; dTARGET;
4335     register AV *ary = (AV*)*++MARK;
4336     register SV *sv;
4337     register I32 i = 0;
4338     MAGIC *mg;
4339
4340     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4341         *MARK-- = SvTIED_obj((SV*)ary, mg);
4342         PUSHMARK(MARK);
4343         PUTBACK;
4344         ENTER;
4345         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4346         LEAVE;
4347         SPAGAIN;
4348     }
4349     else {
4350         av_unshift(ary, SP - MARK);
4351         while (MARK < SP) {
4352             sv = NEWSV(27, 0);
4353             sv_setsv(sv, *++MARK);
4354             (void)av_store(ary, i++, sv);
4355         }
4356     }
4357     SP = ORIGMARK;
4358     PUSHi( AvFILL(ary) + 1 );
4359     RETURN;
4360 }
4361
4362 PP(pp_reverse)
4363 {
4364     dSP; dMARK;
4365     register SV *tmp;
4366     SV **oldsp = SP;
4367
4368     if (GIMME == G_ARRAY) {
4369         MARK++;
4370         while (MARK < SP) {
4371             tmp = *MARK;
4372             *MARK++ = *SP;
4373             *SP-- = tmp;
4374         }
4375         /* safe as long as stack cannot get extended in the above */
4376         SP = oldsp;
4377     }
4378     else {
4379         register char *up;
4380         register char *down;
4381         register I32 tmp;
4382         dTARGET;
4383         STRLEN len;
4384         I32 padoff_du;
4385
4386         SvUTF8_off(TARG);                               /* decontaminate */
4387         if (SP - MARK > 1)
4388             do_join(TARG, &PL_sv_no, MARK, SP);
4389         else
4390             sv_setsv(TARG, (SP > MARK)
4391                     ? *SP
4392                     : (padoff_du = find_rundefsvoffset(),
4393                         (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4394                         ? DEFSV : PAD_SVl(padoff_du)));
4395         up = SvPV_force(TARG, len);
4396         if (len > 1) {
4397             if (DO_UTF8(TARG)) {        /* first reverse each character */
4398                 U8* s = (U8*)SvPVX(TARG);
4399                 U8* send = (U8*)(s + len);
4400                 while (s < send) {
4401                     if (UTF8_IS_INVARIANT(*s)) {
4402                         s++;
4403                         continue;
4404                     }
4405                     else {
4406                         if (!utf8_to_uvchr(s, 0))
4407                             break;
4408                         up = (char*)s;
4409                         s += UTF8SKIP(s);
4410                         down = (char*)(s - 1);
4411                         /* reverse this character */
4412                         while (down > up) {
4413                             tmp = *up;
4414                             *up++ = *down;
4415                             *down-- = (char)tmp;
4416                         }
4417                     }
4418                 }
4419                 up = SvPVX(TARG);
4420             }
4421             down = SvPVX(TARG) + len - 1;
4422             while (down > up) {
4423                 tmp = *up;
4424                 *up++ = *down;
4425                 *down-- = (char)tmp;
4426             }
4427             (void)SvPOK_only_UTF8(TARG);
4428         }
4429         SP = MARK + 1;
4430         SETTARG;
4431     }
4432     RETURN;
4433 }
4434
4435 PP(pp_split)
4436 {
4437     dSP; dTARG;
4438     AV *ary;
4439     register IV limit = POPi;                   /* note, negative is forever */
4440     SV *sv = POPs;
4441     STRLEN len;
4442     register char *s = SvPV(sv, len);
4443     bool do_utf8 = DO_UTF8(sv);
4444     char *strend = s + len;
4445     register PMOP *pm;
4446     register REGEXP *rx;
4447     register SV *dstr;
4448     register char *m;
4449     I32 iters = 0;
4450     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4451     I32 maxiters = slen + 10;
4452     I32 i;
4453     char *orig;
4454     I32 origlimit = limit;
4455     I32 realarray = 0;
4456     I32 base;
4457     I32 gimme = GIMME_V;
4458     I32 oldsave = PL_savestack_ix;
4459     I32 make_mortal = 1;
4460     bool multiline = 0;
4461     MAGIC *mg = (MAGIC *) NULL;
4462
4463 #ifdef DEBUGGING
4464     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4465 #else
4466     pm = (PMOP*)POPs;
4467 #endif
4468     if (!pm || !s)
4469         DIE(aTHX_ "panic: pp_split");
4470     rx = PM_GETRE(pm);
4471
4472     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4473              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4474
4475     RX_MATCH_UTF8_set(rx, do_utf8);
4476
4477     if (pm->op_pmreplroot) {
4478 #ifdef USE_ITHREADS
4479         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4480 #else
4481         ary = GvAVn((GV*)pm->op_pmreplroot);
4482 #endif
4483     }
4484     else if (gimme != G_ARRAY)
4485         ary = GvAVn(PL_defgv);
4486     else
4487         ary = Nullav;
4488     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4489         realarray = 1;
4490         PUTBACK;
4491         av_extend(ary,0);
4492         av_clear(ary);
4493         SPAGAIN;
4494         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4495             PUSHMARK(SP);
4496             XPUSHs(SvTIED_obj((SV*)ary, mg));
4497         }
4498         else {
4499             if (!AvREAL(ary)) {
4500                 AvREAL_on(ary);
4501                 AvREIFY_off(ary);
4502                 for (i = AvFILLp(ary); i >= 0; i--)
4503                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4504             }
4505             /* temporarily switch stacks */
4506             SAVESWITCHSTACK(PL_curstack, ary);
4507             make_mortal = 0;
4508         }
4509     }
4510     base = SP - PL_stack_base;
4511     orig = s;
4512     if (pm->op_pmflags & PMf_SKIPWHITE) {
4513         if (pm->op_pmflags & PMf_LOCALE) {
4514             while (isSPACE_LC(*s))
4515                 s++;
4516         }
4517         else {
4518             while (isSPACE(*s))
4519                 s++;
4520         }
4521     }
4522     if (pm->op_pmflags & PMf_MULTILINE) {
4523         multiline = 1;
4524     }
4525
4526     if (!limit)
4527         limit = maxiters + 2;
4528     if (pm->op_pmflags & PMf_WHITE) {
4529         while (--limit) {
4530             m = s;
4531             while (m < strend &&
4532                    !((pm->op_pmflags & PMf_LOCALE)
4533                      ? isSPACE_LC(*m) : isSPACE(*m)))
4534                 ++m;
4535             if (m >= strend)
4536                 break;
4537
4538             dstr = NEWSV(30, m-s);
4539             sv_setpvn(dstr, s, m-s);
4540             if (make_mortal)
4541                 sv_2mortal(dstr);
4542             if (do_utf8)
4543                 (void)SvUTF8_on(dstr);
4544             XPUSHs(dstr);
4545
4546             s = m + 1;
4547             while (s < strend &&
4548                    ((pm->op_pmflags & PMf_LOCALE)
4549                     ? isSPACE_LC(*s) : isSPACE(*s)))
4550                 ++s;
4551         }
4552     }
4553     else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4554         while (--limit) {
4555             /*SUPPRESS 530*/
4556             for (m = s; m < strend && *m != '\n'; m++) ;
4557             m++;
4558             if (m >= strend)
4559                 break;
4560             dstr = NEWSV(30, m-s);
4561             sv_setpvn(dstr, s, m-s);
4562             if (make_mortal)
4563                 sv_2mortal(dstr);
4564             if (do_utf8)
4565                 (void)SvUTF8_on(dstr);
4566             XPUSHs(dstr);
4567             s = m;
4568         }
4569     }
4570     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4571              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4572              && (rx->reganch & ROPT_CHECK_ALL)
4573              && !(rx->reganch & ROPT_ANCH)) {
4574         int tail = (rx->reganch & RE_INTUIT_TAIL);
4575         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4576
4577         len = rx->minlen;
4578         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4579             STRLEN n_a;
4580             char c = *SvPV(csv, n_a);
4581             while (--limit) {
4582                 /*SUPPRESS 530*/
4583                 for (m = s; m < strend && *m != c; m++) ;
4584                 if (m >= strend)
4585                     break;
4586                 dstr = NEWSV(30, m-s);
4587                 sv_setpvn(dstr, s, m-s);
4588                 if (make_mortal)
4589                     sv_2mortal(dstr);
4590                 if (do_utf8)
4591                     (void)SvUTF8_on(dstr);
4592                 XPUSHs(dstr);
4593                 /* The rx->minlen is in characters but we want to step
4594                  * s ahead by bytes. */
4595                 if (do_utf8)
4596                     s = (char*)utf8_hop((U8*)m, len);
4597                 else
4598                     s = m + len; /* Fake \n at the end */
4599             }
4600         }
4601         else {
4602 #ifndef lint
4603             while (s < strend && --limit &&
4604               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4605                              csv, multiline ? FBMrf_MULTILINE : 0)) )
4606 #endif
4607             {
4608                 dstr = NEWSV(31, m-s);
4609                 sv_setpvn(dstr, s, m-s);
4610                 if (make_mortal)
4611                     sv_2mortal(dstr);
4612                 if (do_utf8)
4613                     (void)SvUTF8_on(dstr);
4614                 XPUSHs(dstr);
4615                 /* The rx->minlen is in characters but we want to step
4616                  * s ahead by bytes. */
4617                 if (do_utf8)
4618                     s = (char*)utf8_hop((U8*)m, len);
4619                 else
4620                     s = m + len; /* Fake \n at the end */
4621             }
4622         }
4623     }
4624     else {
4625         maxiters += slen * rx->nparens;
4626         while (s < strend && --limit)
4627         {
4628             PUTBACK;
4629             i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4630             SPAGAIN;
4631             if (i == 0)
4632                 break;
4633             TAINT_IF(RX_MATCH_TAINTED(rx));
4634             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4635                 m = s;
4636                 s = orig;
4637                 orig = rx->subbeg;
4638                 s = orig + (m - s);
4639                 strend = s + (strend - m);
4640             }
4641             m = rx->startp[0] + orig;
4642             dstr = NEWSV(32, m-s);
4643             sv_setpvn(dstr, s, m-s);
4644             if (make_mortal)
4645                 sv_2mortal(dstr);
4646             if (do_utf8)
4647                 (void)SvUTF8_on(dstr);
4648             XPUSHs(dstr);
4649             if (rx->nparens) {
4650                 for (i = 1; i <= (I32)rx->nparens; i++) {
4651                     s = rx->startp[i] + orig;
4652                     m = rx->endp[i] + orig;
4653
4654                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4655                        parens that didn't match -- they should be set to
4656                        undef, not the empty string */
4657                     if (m >= orig && s >= orig) {
4658                         dstr = NEWSV(33, m-s);
4659                         sv_setpvn(dstr, s, m-s);
4660                     }
4661                     else
4662                         dstr = &PL_sv_undef;  /* undef, not "" */
4663                     if (make_mortal)
4664                         sv_2mortal(dstr);
4665                     if (do_utf8)
4666                         (void)SvUTF8_on(dstr);
4667                     XPUSHs(dstr);
4668                 }
4669             }
4670             s = rx->endp[0] + orig;
4671         }
4672     }
4673
4674     iters = (SP - PL_stack_base) - base;
4675     if (iters > maxiters)
4676         DIE(aTHX_ "Split loop");
4677
4678     /* keep field after final delim? */
4679     if (s < strend || (iters && origlimit)) {
4680         STRLEN l = strend - s;
4681         dstr = NEWSV(34, l);
4682         sv_setpvn(dstr, s, l);
4683         if (make_mortal)
4684             sv_2mortal(dstr);
4685         if (do_utf8)
4686             (void)SvUTF8_on(dstr);
4687         XPUSHs(dstr);
4688         iters++;
4689     }
4690     else if (!origlimit) {
4691         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4692             if (TOPs && !make_mortal)
4693                 sv_2mortal(TOPs);
4694             iters--;
4695             *SP-- = &PL_sv_undef;
4696         }
4697     }
4698
4699     PUTBACK;
4700     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4701     SPAGAIN;
4702     if (realarray) {
4703         if (!mg) {
4704             if (SvSMAGICAL(ary)) {
4705                 PUTBACK;
4706                 mg_set((SV*)ary);
4707                 SPAGAIN;
4708             }
4709             if (gimme == G_ARRAY) {
4710                 EXTEND(SP, iters);
4711                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4712                 SP += iters;
4713                 RETURN;
4714             }
4715         }
4716         else {
4717             PUTBACK;
4718             ENTER;
4719             call_method("PUSH",G_SCALAR|G_DISCARD);
4720             LEAVE;
4721             SPAGAIN;
4722             if (gimme == G_ARRAY) {
4723                 /* EXTEND should not be needed - we just popped them */
4724                 EXTEND(SP, iters);
4725                 for (i=0; i < iters; i++) {
4726                     SV **svp = av_fetch(ary, i, FALSE);
4727                     PUSHs((svp) ? *svp : &PL_sv_undef);
4728                 }
4729                 RETURN;
4730             }
4731         }
4732     }
4733     else {
4734         if (gimme == G_ARRAY)
4735             RETURN;
4736     }
4737
4738     GETTARGET;
4739     PUSHi(iters);
4740     RETURN;
4741 }
4742
4743 PP(pp_lock)
4744 {
4745     dSP;
4746     dTOPss;
4747     SV *retsv = sv;
4748     SvLOCK(sv);
4749     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4750         || SvTYPE(retsv) == SVt_PVCV) {
4751         retsv = refto(retsv);
4752     }
4753     SETs(retsv);
4754     RETURN;
4755 }
4756
4757 PP(pp_threadsv)
4758 {
4759     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4760 }