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