pp.c

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