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