pp.c

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