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