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 = (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
3115             LvTYPE(TARG) = 'x';
3116             if (LvTARG(TARG) != sv) {
3117                 if (LvTARG(TARG))
3118                     SvREFCNT_dec(LvTARG(TARG));
3119                 LvTARG(TARG) = SvREFCNT_inc(sv);
3120             }
3121             LvTARGOFF(TARG) = upos;
3122             LvTARGLEN(TARG) = urem;
3123         }
3124     }
3125     SPAGAIN;
3126     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3127     RETURN;
3128 }
3129
3130 PP(pp_vec)
3131 {
3132     dSP; dTARGET;
3133     register IV size   = POPi;
3134     register IV offset = POPi;
3135     register SV *src = POPs;
3136     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3137
3138     SvTAINTED_off(TARG);                /* decontaminate */
3139     if (lvalue) {                       /* it's an lvalue! */
3140         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3141             TARG = sv_newmortal();
3142         if (SvTYPE(TARG) < SVt_PVLV) {
3143             sv_upgrade(TARG, SVt_PVLV);
3144             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3145         }
3146         LvTYPE(TARG) = 'v';
3147         if (LvTARG(TARG) != src) {
3148             if (LvTARG(TARG))
3149                 SvREFCNT_dec(LvTARG(TARG));
3150             LvTARG(TARG) = SvREFCNT_inc(src);
3151         }
3152         LvTARGOFF(TARG) = offset;
3153         LvTARGLEN(TARG) = size;
3154     }
3155
3156     sv_setuv(TARG, do_vecget(src, offset, size));
3157     PUSHs(TARG);
3158     RETURN;
3159 }
3160
3161 PP(pp_index)
3162 {
3163     dSP; dTARGET;
3164     SV *big;
3165     SV *little;
3166     I32 offset;
3167     I32 retval;
3168     char *tmps;
3169     char *tmps2;
3170     STRLEN biglen;
3171     I32 arybase = PL_curcop->cop_arybase;
3172
3173     if (MAXARG < 3)
3174         offset = 0;
3175     else
3176         offset = POPi - arybase;
3177     little = POPs;
3178     big = POPs;
3179     tmps = SvPV(big, biglen);
3180     if (offset > 0 && DO_UTF8(big))
3181         sv_pos_u2b(big, &offset, 0);
3182     if (offset < 0)
3183         offset = 0;
3184     else if (offset > (I32)biglen)
3185         offset = biglen;
3186     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3187       (unsigned char*)tmps + biglen, little, 0)))
3188         retval = -1;
3189     else
3190         retval = tmps2 - tmps;
3191     if (retval > 0 && DO_UTF8(big))
3192         sv_pos_b2u(big, &retval);
3193     PUSHi(retval + arybase);
3194     RETURN;
3195 }
3196
3197 PP(pp_rindex)
3198 {
3199     dSP; dTARGET;
3200     SV *big;
3201     SV *little;
3202     STRLEN blen;
3203     STRLEN llen;
3204     I32 offset;
3205     I32 retval;
3206     char *tmps;
3207     char *tmps2;
3208     I32 arybase = PL_curcop->cop_arybase;
3209
3210     if (MAXARG >= 3)
3211         offset = POPi;
3212     little = POPs;
3213     big = POPs;
3214     tmps2 = SvPV(little, llen);
3215     tmps = SvPV(big, blen);
3216     if (MAXARG < 3)
3217         offset = blen;
3218     else {
3219         if (offset > 0 && DO_UTF8(big))
3220             sv_pos_u2b(big, &offset, 0);
3221         offset = offset - arybase + llen;
3222     }
3223     if (offset < 0)
3224         offset = 0;
3225     else if (offset > (I32)blen)
3226         offset = blen;
3227     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3228                           tmps2, tmps2 + llen)))
3229         retval = -1;
3230     else
3231         retval = tmps2 - tmps;
3232     if (retval > 0 && DO_UTF8(big))
3233         sv_pos_b2u(big, &retval);
3234     PUSHi(retval + arybase);
3235     RETURN;
3236 }
3237
3238 PP(pp_sprintf)
3239 {
3240     dSP; dMARK; dORIGMARK; dTARGET;
3241     do_sprintf(TARG, SP-MARK, MARK+1);
3242     TAINT_IF(SvTAINTED(TARG));
3243     if (DO_UTF8(*(MARK+1)))
3244         SvUTF8_on(TARG);
3245     SP = ORIGMARK;
3246     PUSHTARG;
3247     RETURN;
3248 }
3249
3250 PP(pp_ord)
3251 {
3252     dSP; dTARGET;
3253     SV *argsv = POPs;
3254     STRLEN len;
3255     U8 *s = (U8*)SvPVx(argsv, len);
3256     SV *tmpsv;
3257
3258     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3259         tmpsv = sv_2mortal(newSVsv(argsv));
3260         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3261         argsv = tmpsv;
3262     }
3263
3264     XPUSHu(DO_UTF8(argsv) ?
3265            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3266            (*s & 0xff));
3267
3268     RETURN;
3269 }
3270
3271 PP(pp_chr)
3272 {
3273     dSP; dTARGET;
3274     char *tmps;
3275     UV value = POPu;
3276
3277     (void)SvUPGRADE(TARG,SVt_PV);
3278
3279     if (value > 255 && !IN_BYTES) {
3280         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3281         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3282         SvCUR_set(TARG, tmps - SvPVX(TARG));
3283         *tmps = '\0';
3284         (void)SvPOK_only(TARG);
3285         SvUTF8_on(TARG);
3286         XPUSHs(TARG);
3287         RETURN;
3288     }
3289
3290     SvGROW(TARG,2);
3291     SvCUR_set(TARG, 1);
3292     tmps = SvPVX(TARG);
3293     *tmps++ = (char)value;
3294     *tmps = '\0';
3295     (void)SvPOK_only(TARG);
3296     if (PL_encoding && !IN_BYTES) {
3297         sv_recode_to_utf8(TARG, PL_encoding);
3298         tmps = SvPVX(TARG);
3299         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3300             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3301             SvGROW(TARG, 3);
3302             tmps = SvPVX(TARG);
3303             SvCUR_set(TARG, 2);
3304             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3305             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3306             *tmps = '\0';
3307             SvUTF8_on(TARG);
3308         }
3309     }
3310     XPUSHs(TARG);
3311     RETURN;
3312 }
3313
3314 PP(pp_crypt)
3315 {
3316     dSP; dTARGET;
3317 #ifdef HAS_CRYPT
3318     dPOPTOPssrl;
3319     STRLEN n_a;
3320     STRLEN len;
3321     char *tmps = SvPV(left, len);
3322
3323     if (DO_UTF8(left)) {
3324          /* If Unicode, try to downgrade.
3325           * If not possible, croak.
3326           * Yes, we made this up.  */
3327          SV* tsv = sv_2mortal(newSVsv(left));
3328
3329          SvUTF8_on(tsv);
3330          sv_utf8_downgrade(tsv, FALSE);
3331          tmps = SvPVX(tsv);
3332     }
3333 #   ifdef USE_ITHREADS
3334 #     ifdef HAS_CRYPT_R
3335     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3336       /* This should be threadsafe because in ithreads there is only
3337        * one thread per interpreter.  If this would not be true,
3338        * we would need a mutex to protect this malloc. */
3339         PL_reentrant_buffer->_crypt_struct_buffer =
3340           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3341 #if defined(__GLIBC__) || defined(__EMX__)
3342         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3343             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3344             /* work around glibc-2.2.5 bug */
3345             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3346         }
3347 #endif
3348     }
3349 #     endif /* HAS_CRYPT_R */
3350 #   endif /* USE_ITHREADS */
3351 #   ifdef FCRYPT
3352     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3353 #   else
3354     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3355 #   endif
3356     SETs(TARG);
3357     RETURN;
3358 #else
3359     DIE(aTHX_
3360       "The crypt() function is unimplemented due to excessive paranoia.");
3361 #endif
3362 }
3363
3364 PP(pp_ucfirst)
3365 {
3366     dSP;
3367     SV *sv = TOPs;
3368     register U8 *s;
3369     STRLEN slen;
3370
3371     SvGETMAGIC(sv);
3372     if (DO_UTF8(sv) &&
3373         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3374         UTF8_IS_START(*s)) {
3375         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3376         STRLEN ulen;
3377         STRLEN tculen;
3378
3379         utf8_to_uvchr(s, &ulen);
3380         toTITLE_utf8(s, tmpbuf, &tculen);
3381         utf8_to_uvchr(tmpbuf, 0);
3382
3383         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3384             dTARGET;
3385             /* slen is the byte length of the whole SV.
3386              * ulen is the byte length of the original Unicode character
3387              * stored as UTF-8 at s.
3388              * tculen is the byte length of the freshly titlecased
3389              * Unicode character stored as UTF-8 at tmpbuf.
3390              * We first set the result to be the titlecased character,
3391              * and then append the rest of the SV data. */
3392             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3393             if (slen > ulen)
3394                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3395             SvUTF8_on(TARG);
3396             SETs(TARG);
3397         }
3398         else {
3399             s = (U8*)SvPV_force_nomg(sv, slen);
3400             Copy(tmpbuf, s, tculen, U8);
3401         }
3402     }
3403     else {
3404         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3405             dTARGET;
3406             SvUTF8_off(TARG);                           /* decontaminate */
3407             sv_setsv_nomg(TARG, sv);
3408             sv = TARG;
3409             SETs(sv);
3410         }
3411         s = (U8*)SvPV_force_nomg(sv, slen);
3412         if (*s) {
3413             if (IN_LOCALE_RUNTIME) {
3414                 TAINT;
3415                 SvTAINTED_on(sv);
3416                 *s = toUPPER_LC(*s);
3417             }
3418             else
3419                 *s = toUPPER(*s);
3420         }
3421     }
3422     SvSETMAGIC(sv);
3423     RETURN;
3424 }
3425
3426 PP(pp_lcfirst)
3427 {
3428     dSP;
3429     SV *sv = TOPs;
3430     register U8 *s;
3431     STRLEN slen;
3432
3433     SvGETMAGIC(sv);
3434     if (DO_UTF8(sv) &&
3435         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3436         UTF8_IS_START(*s)) {
3437         STRLEN ulen;
3438         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3439         U8 *tend;
3440         UV uv;
3441
3442         toLOWER_utf8(s, tmpbuf, &ulen);
3443         uv = utf8_to_uvchr(tmpbuf, 0);
3444         tend = uvchr_to_utf8(tmpbuf, uv);
3445
3446         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3447             dTARGET;
3448             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3449             if (slen > ulen)
3450                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3451             SvUTF8_on(TARG);
3452             SETs(TARG);
3453         }
3454         else {
3455             s = (U8*)SvPV_force_nomg(sv, slen);
3456             Copy(tmpbuf, s, ulen, U8);
3457         }
3458     }
3459     else {
3460         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3461             dTARGET;
3462             SvUTF8_off(TARG);                           /* decontaminate */
3463             sv_setsv_nomg(TARG, sv);
3464             sv = TARG;
3465             SETs(sv);
3466         }
3467         s = (U8*)SvPV_force_nomg(sv, slen);
3468         if (*s) {
3469             if (IN_LOCALE_RUNTIME) {
3470                 TAINT;
3471                 SvTAINTED_on(sv);
3472                 *s = toLOWER_LC(*s);
3473             }
3474             else
3475                 *s = toLOWER(*s);
3476         }
3477     }
3478     SvSETMAGIC(sv);
3479     RETURN;
3480 }
3481
3482 PP(pp_uc)
3483 {
3484     dSP;
3485     SV *sv = TOPs;
3486     register U8 *s;
3487     STRLEN len;
3488
3489     SvGETMAGIC(sv);
3490     if (DO_UTF8(sv)) {
3491         dTARGET;
3492         STRLEN ulen;
3493         register U8 *d;
3494         U8 *send;
3495         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3496
3497         s = (U8*)SvPV_nomg(sv,len);
3498         if (!len) {
3499             SvUTF8_off(TARG);                           /* decontaminate */
3500             sv_setpvn(TARG, "", 0);
3501             SETs(TARG);
3502         }
3503         else {
3504             STRLEN nchar = utf8_length(s, s + len);
3505
3506             (void)SvUPGRADE(TARG, SVt_PV);
3507             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3508             (void)SvPOK_only(TARG);
3509             d = (U8*)SvPVX(TARG);
3510             send = s + len;
3511             while (s < send) {
3512                 toUPPER_utf8(s, tmpbuf, &ulen);
3513                 Copy(tmpbuf, d, ulen, U8);
3514                 d += ulen;
3515                 s += UTF8SKIP(s);
3516             }
3517             *d = '\0';
3518             SvUTF8_on(TARG);
3519             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3520             SETs(TARG);
3521         }
3522     }
3523     else {
3524         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3525             dTARGET;
3526             SvUTF8_off(TARG);                           /* decontaminate */
3527             sv_setsv_nomg(TARG, sv);
3528             sv = TARG;
3529             SETs(sv);
3530         }
3531         s = (U8*)SvPV_force_nomg(sv, len);
3532         if (len) {
3533             register U8 *send = s + len;
3534
3535             if (IN_LOCALE_RUNTIME) {
3536                 TAINT;
3537                 SvTAINTED_on(sv);
3538                 for (; s < send; s++)
3539                     *s = toUPPER_LC(*s);
3540             }
3541             else {
3542                 for (; s < send; s++)
3543                     *s = toUPPER(*s);
3544             }
3545         }
3546     }
3547     SvSETMAGIC(sv);
3548     RETURN;
3549 }
3550
3551 PP(pp_lc)
3552 {
3553     dSP;
3554     SV *sv = TOPs;
3555     register U8 *s;
3556     STRLEN len;
3557
3558     SvGETMAGIC(sv);
3559     if (DO_UTF8(sv)) {
3560         dTARGET;
3561         STRLEN ulen;
3562         register U8 *d;
3563         U8 *send;
3564         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3565
3566         s = (U8*)SvPV_nomg(sv,len);
3567         if (!len) {
3568             SvUTF8_off(TARG);                           /* decontaminate */
3569             sv_setpvn(TARG, "", 0);
3570             SETs(TARG);
3571         }
3572         else {
3573             STRLEN nchar = utf8_length(s, s + len);
3574
3575             (void)SvUPGRADE(TARG, SVt_PV);
3576             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3577             (void)SvPOK_only(TARG);
3578             d = (U8*)SvPVX(TARG);
3579             send = s + len;
3580             while (s < send) {
3581                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3582 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3583                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3584                      /*
3585                       * Now if the sigma is NOT followed by
3586                       * /$ignorable_sequence$cased_letter/;
3587                       * and it IS preceded by
3588                       * /$cased_letter$ignorable_sequence/;
3589                       * where $ignorable_sequence is
3590                       * [\x{2010}\x{AD}\p{Mn}]*
3591                       * and $cased_letter is
3592                       * [\p{Ll}\p{Lo}\p{Lt}]
3593                       * then it should be mapped to 0x03C2,
3594                       * (GREEK SMALL LETTER FINAL SIGMA),
3595                       * instead of staying 0x03A3.
3596                       * See lib/unicore/SpecCase.txt.
3597                       */
3598                 }
3599                 Copy(tmpbuf, d, ulen, U8);
3600                 d += ulen;
3601                 s += UTF8SKIP(s);
3602             }
3603             *d = '\0';
3604             SvUTF8_on(TARG);
3605             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3606             SETs(TARG);
3607         }
3608     }
3609     else {
3610         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3611             dTARGET;
3612             SvUTF8_off(TARG);                           /* decontaminate */
3613             sv_setsv_nomg(TARG, sv);
3614             sv = TARG;
3615             SETs(sv);
3616         }
3617
3618         s = (U8*)SvPV_force_nomg(sv, len);
3619         if (len) {
3620             register U8 *send = s + len;
3621
3622             if (IN_LOCALE_RUNTIME) {
3623                 TAINT;
3624                 SvTAINTED_on(sv);
3625                 for (; s < send; s++)
3626                     *s = toLOWER_LC(*s);
3627             }
3628             else {
3629                 for (; s < send; s++)
3630                     *s = toLOWER(*s);
3631             }
3632         }
3633     }
3634     SvSETMAGIC(sv);
3635     RETURN;
3636 }
3637
3638 PP(pp_quotemeta)
3639 {
3640     dSP; dTARGET;
3641     SV *sv = TOPs;
3642     STRLEN len;
3643     register char *s = SvPV(sv,len);
3644     register char *d;
3645
3646     SvUTF8_off(TARG);                           /* decontaminate */
3647     if (len) {
3648         (void)SvUPGRADE(TARG, SVt_PV);
3649         SvGROW(TARG, (len * 2) + 1);
3650         d = SvPVX(TARG);
3651         if (DO_UTF8(sv)) {
3652             while (len) {
3653                 if (UTF8_IS_CONTINUED(*s)) {
3654                     STRLEN ulen = UTF8SKIP(s);
3655                     if (ulen > len)
3656                         ulen = len;
3657                     len -= ulen;
3658                     while (ulen--)
3659                         *d++ = *s++;
3660                 }
3661                 else {
3662                     if (!isALNUM(*s))
3663                         *d++ = '\\';
3664                     *d++ = *s++;
3665                     len--;
3666                 }
3667             }
3668             SvUTF8_on(TARG);
3669         }
3670         else {
3671             while (len--) {
3672                 if (!isALNUM(*s))
3673                     *d++ = '\\';
3674                 *d++ = *s++;
3675             }
3676         }
3677         *d = '\0';
3678         SvCUR_set(TARG, d - SvPVX(TARG));
3679         (void)SvPOK_only_UTF8(TARG);
3680     }
3681     else
3682         sv_setpvn(TARG, s, len);
3683     SETs(TARG);
3684     if (SvSMAGICAL(TARG))
3685         mg_set(TARG);
3686     RETURN;
3687 }
3688
3689 /* Arrays. */
3690
3691 PP(pp_aslice)
3692 {
3693     dSP; dMARK; dORIGMARK;
3694     register SV** svp;
3695     register AV* av = (AV*)POPs;
3696     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3697     I32 arybase = PL_curcop->cop_arybase;
3698     I32 elem;
3699
3700     if (SvTYPE(av) == SVt_PVAV) {
3701         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3702             I32 max = -1;
3703             for (svp = MARK + 1; svp <= SP; svp++) {
3704                 elem = SvIVx(*svp);
3705                 if (elem > max)
3706                     max = elem;
3707             }
3708             if (max > AvMAX(av))
3709                 av_extend(av, max);
3710         }
3711         while (++MARK <= SP) {
3712             elem = SvIVx(*MARK);
3713
3714             if (elem > 0)
3715                 elem -= arybase;
3716             svp = av_fetch(av, elem, lval);
3717             if (lval) {
3718                 if (!svp || *svp == &PL_sv_undef)
3719                     DIE(aTHX_ PL_no_aelem, elem);
3720                 if (PL_op->op_private & OPpLVAL_INTRO)
3721                     save_aelem(av, elem, svp);
3722             }
3723             *MARK = svp ? *svp : &PL_sv_undef;
3724         }
3725     }
3726     if (GIMME != G_ARRAY) {
3727         MARK = ORIGMARK;
3728         *++MARK = *SP;
3729         SP = MARK;
3730     }
3731     RETURN;
3732 }
3733
3734 /* Associative arrays. */
3735
3736 PP(pp_each)
3737 {
3738     dSP;
3739     HV *hash = (HV*)POPs;
3740     HE *entry;
3741     I32 gimme = GIMME_V;
3742
3743     PUTBACK;
3744     /* might clobber stack_sp */
3745     entry = hv_iternext(hash);
3746     SPAGAIN;
3747
3748     EXTEND(SP, 2);
3749     if (entry) {
3750         SV* sv = hv_iterkeysv(entry);
3751         PUSHs(sv);      /* won't clobber stack_sp */
3752         if (gimme == G_ARRAY) {
3753             SV *val;
3754             PUTBACK;
3755             /* might clobber stack_sp */
3756             val = hv_iterval(hash, entry);
3757             SPAGAIN;
3758             PUSHs(val);
3759         }
3760     }
3761     else if (gimme == G_SCALAR)
3762         RETPUSHUNDEF;
3763
3764     RETURN;
3765 }
3766
3767 PP(pp_values)
3768 {
3769     return do_kv();
3770 }
3771
3772 PP(pp_keys)
3773 {
3774     return do_kv();
3775 }
3776
3777 PP(pp_delete)
3778 {
3779     dSP;
3780     I32 gimme = GIMME_V;
3781     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3782     SV *sv;
3783     HV *hv;
3784
3785     if (PL_op->op_private & OPpSLICE) {
3786         dMARK; dORIGMARK;
3787         U32 hvtype;
3788         hv = (HV*)POPs;
3789         hvtype = SvTYPE(hv);
3790         if (hvtype == SVt_PVHV) {                       /* hash element */
3791             while (++MARK <= SP) {
3792                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3793                 *MARK = sv ? sv : &PL_sv_undef;
3794             }
3795         }
3796         else if (hvtype == SVt_PVAV) {                  /* array element */
3797             if (PL_op->op_flags & OPf_SPECIAL) {
3798                 while (++MARK <= SP) {
3799                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3800                     *MARK = sv ? sv : &PL_sv_undef;
3801                 }
3802             }
3803         }
3804         else
3805             DIE(aTHX_ "Not a HASH reference");
3806         if (discard)
3807             SP = ORIGMARK;
3808         else if (gimme == G_SCALAR) {
3809             MARK = ORIGMARK;
3810             *++MARK = *SP;
3811             SP = MARK;
3812         }
3813     }
3814     else {
3815         SV *keysv = POPs;
3816         hv = (HV*)POPs;
3817         if (SvTYPE(hv) == SVt_PVHV)
3818             sv = hv_delete_ent(hv, keysv, discard, 0);
3819         else if (SvTYPE(hv) == SVt_PVAV) {
3820             if (PL_op->op_flags & OPf_SPECIAL)
3821                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3822             else
3823                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3824         }
3825         else
3826             DIE(aTHX_ "Not a HASH reference");
3827         if (!sv)
3828             sv = &PL_sv_undef;
3829         if (!discard)
3830             PUSHs(sv);
3831     }
3832     RETURN;
3833 }
3834
3835 PP(pp_exists)
3836 {
3837     dSP;
3838     SV *tmpsv;
3839     HV *hv;
3840
3841     if (PL_op->op_private & OPpEXISTS_SUB) {
3842         GV *gv;
3843         CV *cv;
3844         SV *sv = POPs;
3845         cv = sv_2cv(sv, &hv, &gv, FALSE);
3846         if (cv)
3847             RETPUSHYES;
3848         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3849             RETPUSHYES;
3850         RETPUSHNO;
3851     }
3852     tmpsv = POPs;
3853     hv = (HV*)POPs;
3854     if (SvTYPE(hv) == SVt_PVHV) {
3855         if (hv_exists_ent(hv, tmpsv, 0))
3856             RETPUSHYES;
3857     }
3858     else if (SvTYPE(hv) == SVt_PVAV) {
3859         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3860             if (av_exists((AV*)hv, SvIV(tmpsv)))
3861                 RETPUSHYES;
3862         }
3863     }
3864     else {
3865         DIE(aTHX_ "Not a HASH reference");
3866     }
3867     RETPUSHNO;
3868 }
3869
3870 PP(pp_hslice)
3871 {
3872     dSP; dMARK; dORIGMARK;
3873     register HV *hv = (HV*)POPs;
3874     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3875     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3876     bool other_magic = FALSE;
3877
3878     if (localizing) {
3879         MAGIC *mg;
3880         HV *stash;
3881
3882         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3883             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3884              /* Try to preserve the existenceness of a tied hash
3885               * element by using EXISTS and DELETE if possible.
3886               * Fallback to FETCH and STORE otherwise */
3887              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3888              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3889              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3890     }
3891
3892     while (++MARK <= SP) {
3893         SV *keysv = *MARK;
3894         SV **svp;
3895         HE *he;
3896         bool preeminent = FALSE;
3897
3898         if (localizing) {
3899             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3900                 hv_exists_ent(hv, keysv, 0);
3901         }
3902
3903         he = hv_fetch_ent(hv, keysv, lval, 0);
3904         svp = he ? &HeVAL(he) : 0;
3905
3906         if (lval) {
3907             if (!svp || *svp == &PL_sv_undef) {
3908                 STRLEN n_a;
3909                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3910             }
3911             if (localizing) {
3912                 if (preeminent)
3913                     save_helem(hv, keysv, svp);
3914                 else {
3915                     STRLEN keylen;
3916                     char *key = SvPV(keysv, keylen);
3917                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3918                 }
3919             }
3920         }
3921         *MARK = svp ? *svp : &PL_sv_undef;
3922     }
3923     if (GIMME != G_ARRAY) {
3924         MARK = ORIGMARK;
3925         *++MARK = *SP;
3926         SP = MARK;
3927     }
3928     RETURN;
3929 }
3930
3931 /* List operators. */
3932
3933 PP(pp_list)
3934 {
3935     dSP; dMARK;
3936     if (GIMME != G_ARRAY) {
3937         if (++MARK <= SP)
3938             *MARK = *SP;                /* unwanted list, return last item */
3939         else
3940             *MARK = &PL_sv_undef;
3941         SP = MARK;
3942     }
3943     RETURN;
3944 }
3945
3946 PP(pp_lslice)
3947 {
3948     dSP;
3949     SV **lastrelem = PL_stack_sp;
3950     SV **lastlelem = PL_stack_base + POPMARK;
3951     SV **firstlelem = PL_stack_base + POPMARK + 1;
3952     register SV **firstrelem = lastlelem + 1;
3953     I32 arybase = PL_curcop->cop_arybase;
3954     I32 lval = PL_op->op_flags & OPf_MOD;
3955     I32 is_something_there = lval;
3956
3957     register I32 max = lastrelem - lastlelem;
3958     register SV **lelem;
3959     register I32 ix;
3960
3961     if (GIMME != G_ARRAY) {
3962         ix = SvIVx(*lastlelem);
3963         if (ix < 0)
3964             ix += max;
3965         else
3966             ix -= arybase;
3967         if (ix < 0 || ix >= max)
3968             *firstlelem = &PL_sv_undef;
3969         else
3970             *firstlelem = firstrelem[ix];
3971         SP = firstlelem;
3972         RETURN;
3973     }
3974
3975     if (max == 0) {
3976         SP = firstlelem - 1;
3977         RETURN;
3978     }
3979
3980     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3981         ix = SvIVx(*lelem);
3982         if (ix < 0)
3983             ix += max;
3984         else
3985             ix -= arybase;
3986         if (ix < 0 || ix >= max)
3987             *lelem = &PL_sv_undef;
3988         else {
3989             is_something_there = TRUE;
3990             if (!(*lelem = firstrelem[ix]))
3991                 *lelem = &PL_sv_undef;
3992         }
3993     }
3994     if (is_something_there)
3995         SP = lastlelem;
3996     else
3997         SP = firstlelem - 1;
3998     RETURN;
3999 }
4000
4001 PP(pp_anonlist)
4002 {
4003     dSP; dMARK; dORIGMARK;
4004     I32 items = SP - MARK;
4005     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4006     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4007     XPUSHs(av);
4008     RETURN;
4009 }
4010
4011 PP(pp_anonhash)
4012 {
4013     dSP; dMARK; dORIGMARK;
4014     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4015
4016     while (MARK < SP) {
4017         SV* key = *++MARK;
4018         SV *val = NEWSV(46, 0);
4019         if (MARK < SP)
4020             sv_setsv(val, *++MARK);
4021         else if (ckWARN(WARN_MISC))
4022             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4023         (void)hv_store_ent(hv,key,val,0);
4024     }
4025     SP = ORIGMARK;
4026     XPUSHs((SV*)hv);
4027     RETURN;
4028 }
4029
4030 PP(pp_splice)
4031 {
4032     dSP; dMARK; dORIGMARK;
4033     register AV *ary = (AV*)*++MARK;
4034     register SV **src;
4035     register SV **dst;
4036     register I32 i;
4037     register I32 offset;
4038     register I32 length;
4039     I32 newlen;
4040     I32 after;
4041     I32 diff;
4042     SV **tmparyval = 0;
4043     MAGIC *mg;
4044
4045     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4046         *MARK-- = SvTIED_obj((SV*)ary, mg);
4047         PUSHMARK(MARK);
4048         PUTBACK;
4049         ENTER;
4050         call_method("SPLICE",GIMME_V);
4051         LEAVE;
4052         SPAGAIN;
4053         RETURN;
4054     }
4055
4056     SP++;
4057
4058     if (++MARK < SP) {
4059         offset = i = SvIVx(*MARK);
4060         if (offset < 0)
4061             offset += AvFILLp(ary) + 1;
4062         else
4063             offset -= PL_curcop->cop_arybase;
4064         if (offset < 0)
4065             DIE(aTHX_ PL_no_aelem, i);
4066         if (++MARK < SP) {
4067             length = SvIVx(*MARK++);
4068             if (length < 0) {
4069                 length += AvFILLp(ary) - offset + 1;
4070                 if (length < 0)
4071                     length = 0;
4072             }
4073         }
4074         else
4075             length = AvMAX(ary) + 1;            /* close enough to infinity */
4076     }
4077     else {
4078         offset = 0;
4079         length = AvMAX(ary) + 1;
4080     }
4081     if (offset > AvFILLp(ary) + 1) {
4082         if (ckWARN(WARN_MISC))
4083             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4084         offset = AvFILLp(ary) + 1;
4085     }
4086     after = AvFILLp(ary) + 1 - (offset + length);
4087     if (after < 0) {                            /* not that much array */
4088         length += after;                        /* offset+length now in array */
4089         after = 0;
4090         if (!AvALLOC(ary))
4091             av_extend(ary, 0);
4092     }
4093
4094     /* At this point, MARK .. SP-1 is our new LIST */
4095
4096     newlen = SP - MARK;
4097     diff = newlen - length;
4098     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4099         av_reify(ary);
4100
4101     if (diff < 0) {                             /* shrinking the area */
4102         if (newlen) {
4103             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4104             Copy(MARK, tmparyval, newlen, SV*);
4105         }
4106
4107         MARK = ORIGMARK + 1;
4108         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4109             MEXTEND(MARK, length);
4110             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4111             if (AvREAL(ary)) {
4112                 EXTEND_MORTAL(length);
4113                 for (i = length, dst = MARK; i; i--) {
4114                     sv_2mortal(*dst);   /* free them eventualy */
4115                     dst++;
4116                 }
4117             }
4118             MARK += length - 1;
4119         }
4120         else {
4121             *MARK = AvARRAY(ary)[offset+length-1];
4122             if (AvREAL(ary)) {
4123                 sv_2mortal(*MARK);
4124                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4125                     SvREFCNT_dec(*dst++);       /* free them now */
4126             }
4127         }
4128         AvFILLp(ary) += diff;
4129
4130         /* pull up or down? */
4131
4132         if (offset < after) {                   /* easier to pull up */
4133             if (offset) {                       /* esp. if nothing to pull */
4134                 src = &AvARRAY(ary)[offset-1];
4135                 dst = src - diff;               /* diff is negative */
4136                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4137                     *dst-- = *src--;
4138             }
4139             dst = AvARRAY(ary);
4140             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4141             AvMAX(ary) += diff;
4142         }
4143         else {
4144             if (after) {                        /* anything to pull down? */
4145                 src = AvARRAY(ary) + offset + length;
4146                 dst = src + diff;               /* diff is negative */
4147                 Move(src, dst, after, SV*);
4148             }
4149             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4150                                                 /* avoid later double free */
4151         }
4152         i = -diff;
4153         while (i)
4154             dst[--i] = &PL_sv_undef;
4155
4156         if (newlen) {
4157             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4158               newlen; newlen--) {
4159                 *dst = NEWSV(46, 0);
4160                 sv_setsv(*dst++, *src++);
4161             }
4162             Safefree(tmparyval);
4163         }
4164     }
4165     else {                                      /* no, expanding (or same) */
4166         if (length) {
4167             New(452, tmparyval, length, SV*);   /* so remember deletion */
4168             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4169         }
4170
4171         if (diff > 0) {                         /* expanding */
4172
4173             /* push up or down? */
4174
4175             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4176                 if (offset) {
4177                     src = AvARRAY(ary);
4178                     dst = src - diff;
4179                     Move(src, dst, offset, SV*);
4180                 }
4181                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4182                 AvMAX(ary) += diff;
4183                 AvFILLp(ary) += diff;
4184             }
4185             else {
4186                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4187                     av_extend(ary, AvFILLp(ary) + diff);
4188                 AvFILLp(ary) += diff;
4189
4190                 if (after) {
4191                     dst = AvARRAY(ary) + AvFILLp(ary);
4192                     src = dst - diff;
4193                     for (i = after; i; i--) {
4194                         *dst-- = *src--;
4195                     }
4196                 }
4197             }
4198         }
4199
4200         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4201             *dst = NEWSV(46, 0);
4202             sv_setsv(*dst++, *src++);
4203         }
4204         MARK = ORIGMARK + 1;
4205         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4206             if (length) {
4207                 Copy(tmparyval, MARK, length, SV*);
4208                 if (AvREAL(ary)) {
4209                     EXTEND_MORTAL(length);
4210                     for (i = length, dst = MARK; i; i--) {
4211                         sv_2mortal(*dst);       /* free them eventualy */
4212                         dst++;
4213                     }
4214                 }
4215                 Safefree(tmparyval);
4216             }
4217             MARK += length - 1;
4218         }
4219         else if (length--) {
4220             *MARK = tmparyval[length];
4221             if (AvREAL(ary)) {
4222                 sv_2mortal(*MARK);
4223                 while (length-- > 0)
4224                     SvREFCNT_dec(tmparyval[length]);
4225             }
4226             Safefree(tmparyval);
4227         }
4228         else
4229             *MARK = &PL_sv_undef;
4230     }
4231     SP = MARK;
4232     RETURN;
4233 }
4234
4235 PP(pp_push)
4236 {
4237     dSP; dMARK; dORIGMARK; dTARGET;
4238     register AV *ary = (AV*)*++MARK;
4239     register SV *sv = &PL_sv_undef;
4240     MAGIC *mg;
4241
4242     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4243         *MARK-- = SvTIED_obj((SV*)ary, mg);
4244         PUSHMARK(MARK);
4245         PUTBACK;
4246         ENTER;
4247         call_method("PUSH",G_SCALAR|G_DISCARD);
4248         LEAVE;
4249         SPAGAIN;
4250     }
4251     else {
4252         /* Why no pre-extend of ary here ? */
4253         for (++MARK; MARK <= SP; MARK++) {
4254             sv = NEWSV(51, 0);
4255             if (*MARK)
4256                 sv_setsv(sv, *MARK);
4257             av_push(ary, sv);
4258         }
4259     }
4260     SP = ORIGMARK;
4261     PUSHi( AvFILL(ary) + 1 );
4262     RETURN;
4263 }
4264
4265 PP(pp_pop)
4266 {
4267     dSP;
4268     AV *av = (AV*)POPs;
4269     SV *sv = av_pop(av);
4270     if (AvREAL(av))
4271         (void)sv_2mortal(sv);
4272     PUSHs(sv);
4273     RETURN;
4274 }
4275
4276 PP(pp_shift)
4277 {
4278     dSP;
4279     AV *av = (AV*)POPs;
4280     SV *sv = av_shift(av);
4281     EXTEND(SP, 1);
4282     if (!sv)
4283         RETPUSHUNDEF;
4284     if (AvREAL(av))
4285         (void)sv_2mortal(sv);
4286     PUSHs(sv);
4287     RETURN;
4288 }
4289
4290 PP(pp_unshift)
4291 {
4292     dSP; dMARK; dORIGMARK; dTARGET;
4293     register AV *ary = (AV*)*++MARK;
4294     register SV *sv;
4295     register I32 i = 0;
4296     MAGIC *mg;
4297
4298     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4299         *MARK-- = SvTIED_obj((SV*)ary, mg);
4300         PUSHMARK(MARK);
4301         PUTBACK;
4302         ENTER;
4303         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4304         LEAVE;
4305         SPAGAIN;
4306     }
4307     else {
4308         av_unshift(ary, SP - MARK);
4309         while (MARK < SP) {
4310             sv = NEWSV(27, 0);
4311             sv_setsv(sv, *++MARK);
4312             (void)av_store(ary, i++, sv);
4313         }
4314     }
4315     SP = ORIGMARK;
4316     PUSHi( AvFILL(ary) + 1 );
4317     RETURN;
4318 }
4319
4320 PP(pp_reverse)
4321 {
4322     dSP; dMARK;
4323     register SV *tmp;
4324     SV **oldsp = SP;
4325
4326     if (GIMME == G_ARRAY) {
4327         MARK++;
4328         while (MARK < SP) {
4329             tmp = *MARK;
4330             *MARK++ = *SP;
4331             *SP-- = tmp;
4332         }
4333         /* safe as long as stack cannot get extended in the above */
4334         SP = oldsp;
4335     }
4336     else {
4337         register char *up;
4338         register char *down;
4339         register I32 tmp;
4340         dTARGET;
4341         STRLEN len;
4342
4343         SvUTF8_off(TARG);                               /* decontaminate */
4344         if (SP - MARK > 1)
4345             do_join(TARG, &PL_sv_no, MARK, SP);
4346         else
4347             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4348         up = SvPV_force(TARG, len);
4349         if (len > 1) {
4350             if (DO_UTF8(TARG)) {        /* first reverse each character */
4351                 U8* s = (U8*)SvPVX(TARG);
4352                 U8* send = (U8*)(s + len);
4353                 while (s < send) {
4354                     if (UTF8_IS_INVARIANT(*s)) {
4355                         s++;
4356                         continue;
4357                     }
4358                     else {
4359                         if (!utf8_to_uvchr(s, 0))
4360                             break;
4361                         up = (char*)s;
4362                         s += UTF8SKIP(s);
4363                         down = (char*)(s - 1);
4364                         /* reverse this character */
4365                         while (down > up) {
4366                             tmp = *up;
4367                             *up++ = *down;
4368                             *down-- = (char)tmp;
4369                         }
4370                     }
4371                 }
4372                 up = SvPVX(TARG);
4373             }
4374             down = SvPVX(TARG) + len - 1;
4375             while (down > up) {
4376                 tmp = *up;
4377                 *up++ = *down;
4378                 *down-- = (char)tmp;
4379             }
4380             (void)SvPOK_only_UTF8(TARG);
4381         }
4382         SP = MARK + 1;
4383         SETTARG;
4384     }
4385     RETURN;
4386 }
4387
4388 PP(pp_split)
4389 {
4390     dSP; dTARG;
4391     AV *ary;
4392     register IV limit = POPi;                   /* note, negative is forever */
4393     SV *sv = POPs;
4394     STRLEN len;
4395     register char *s = SvPV(sv, len);
4396     bool do_utf8 = DO_UTF8(sv);
4397     char *strend = s + len;
4398     register PMOP *pm;
4399     register REGEXP *rx;
4400     register SV *dstr;
4401     register char *m;
4402     I32 iters = 0;
4403     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4404     I32 maxiters = slen + 10;
4405     I32 i;
4406     char *orig;
4407     I32 origlimit = limit;
4408     I32 realarray = 0;
4409     I32 base;
4410     AV *oldstack = PL_curstack;
4411     I32 gimme = GIMME_V;
4412     I32 oldsave = PL_savestack_ix;
4413     I32 make_mortal = 1;
4414     MAGIC *mg = (MAGIC *) NULL;
4415
4416 #ifdef DEBUGGING
4417     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4418 #else
4419     pm = (PMOP*)POPs;
4420 #endif
4421     if (!pm || !s)
4422         DIE(aTHX_ "panic: pp_split");
4423     rx = PM_GETRE(pm);
4424
4425     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4426              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4427
4428     RX_MATCH_UTF8_set(rx, do_utf8);
4429
4430     if (pm->op_pmreplroot) {
4431 #ifdef USE_ITHREADS
4432         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4433 #else
4434         ary = GvAVn((GV*)pm->op_pmreplroot);
4435 #endif
4436     }
4437     else if (gimme != G_ARRAY)
4438         ary = GvAVn(PL_defgv);
4439     else
4440         ary = Nullav;
4441     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4442         realarray = 1;
4443         PUTBACK;
4444         av_extend(ary,0);
4445         av_clear(ary);
4446         SPAGAIN;
4447         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4448             PUSHMARK(SP);
4449             XPUSHs(SvTIED_obj((SV*)ary, mg));
4450         }
4451         else {
4452             if (!AvREAL(ary)) {
4453                 AvREAL_on(ary);
4454                 AvREIFY_off(ary);
4455                 for (i = AvFILLp(ary); i >= 0; i--)
4456                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4457             }
4458             /* temporarily switch stacks */
4459             SWITCHSTACK(PL_curstack, ary);
4460             PL_curstackinfo->si_stack = ary;
4461             make_mortal = 0;
4462         }
4463     }
4464     base = SP - PL_stack_base;
4465     orig = s;
4466     if (pm->op_pmflags & PMf_SKIPWHITE) {
4467         if (pm->op_pmflags & PMf_LOCALE) {
4468             while (isSPACE_LC(*s))
4469                 s++;
4470         }
4471         else {
4472             while (isSPACE(*s))
4473                 s++;
4474         }
4475     }
4476     if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4477         SAVEINT(PL_multiline);
4478         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4479     }
4480
4481     if (!limit)
4482         limit = maxiters + 2;
4483     if (pm->op_pmflags & PMf_WHITE) {
4484         while (--limit) {
4485             m = s;
4486             while (m < strend &&
4487                    !((pm->op_pmflags & PMf_LOCALE)
4488                      ? isSPACE_LC(*m) : isSPACE(*m)))
4489                 ++m;
4490             if (m >= strend)
4491                 break;
4492
4493             dstr = NEWSV(30, m-s);
4494             sv_setpvn(dstr, s, m-s);
4495             if (make_mortal)
4496                 sv_2mortal(dstr);
4497             if (do_utf8)
4498                 (void)SvUTF8_on(dstr);
4499             XPUSHs(dstr);
4500
4501             s = m + 1;
4502             while (s < strend &&
4503                    ((pm->op_pmflags & PMf_LOCALE)
4504                     ? isSPACE_LC(*s) : isSPACE(*s)))
4505                 ++s;
4506         }
4507     }
4508     else if (strEQ("^", rx->precomp)) {
4509         while (--limit) {
4510             /*SUPPRESS 530*/
4511             for (m = s; m < strend && *m != '\n'; m++) ;
4512             m++;
4513             if (m >= strend)
4514                 break;
4515             dstr = NEWSV(30, m-s);
4516             sv_setpvn(dstr, s, m-s);
4517             if (make_mortal)
4518                 sv_2mortal(dstr);
4519             if (do_utf8)
4520                 (void)SvUTF8_on(dstr);
4521             XPUSHs(dstr);
4522             s = m;
4523         }
4524     }
4525     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4526              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4527              && (rx->reganch & ROPT_CHECK_ALL)
4528              && !(rx->reganch & ROPT_ANCH)) {
4529         int tail = (rx->reganch & RE_INTUIT_TAIL);
4530         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4531
4532         len = rx->minlen;
4533         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4534             STRLEN n_a;
4535             char c = *SvPV(csv, n_a);
4536             while (--limit) {
4537                 /*SUPPRESS 530*/
4538                 for (m = s; m < strend && *m != c; m++) ;
4539                 if (m >= strend)
4540                     break;
4541                 dstr = NEWSV(30, m-s);
4542                 sv_setpvn(dstr, s, m-s);
4543                 if (make_mortal)
4544                     sv_2mortal(dstr);
4545                 if (do_utf8)
4546                     (void)SvUTF8_on(dstr);
4547                 XPUSHs(dstr);
4548                 /* The rx->minlen is in characters but we want to step
4549                  * s ahead by bytes. */
4550                 if (do_utf8)
4551                     s = (char*)utf8_hop((U8*)m, len);
4552                 else
4553                     s = m + len; /* Fake \n at the end */
4554             }
4555         }
4556         else {
4557 #ifndef lint
4558             while (s < strend && --limit &&
4559               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4560                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4561 #endif
4562             {
4563                 dstr = NEWSV(31, m-s);
4564                 sv_setpvn(dstr, s, m-s);
4565                 if (make_mortal)
4566                     sv_2mortal(dstr);
4567                 if (do_utf8)
4568                     (void)SvUTF8_on(dstr);
4569                 XPUSHs(dstr);
4570                 /* The rx->minlen is in characters but we want to step
4571                  * s ahead by bytes. */
4572                 if (do_utf8)
4573                     s = (char*)utf8_hop((U8*)m, len);
4574                 else
4575                     s = m + len; /* Fake \n at the end */
4576             }
4577         }
4578     }
4579     else {
4580         maxiters += slen * rx->nparens;
4581         while (s < strend && --limit)
4582         {
4583             PUTBACK;
4584             i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4585             SPAGAIN;
4586             if (i == 0)
4587                 break;
4588             TAINT_IF(RX_MATCH_TAINTED(rx));
4589             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4590                 m = s;
4591                 s = orig;
4592                 orig = rx->subbeg;
4593                 s = orig + (m - s);
4594                 strend = s + (strend - m);
4595             }
4596             m = rx->startp[0] + orig;
4597             dstr = NEWSV(32, m-s);
4598             sv_setpvn(dstr, s, m-s);
4599             if (make_mortal)
4600                 sv_2mortal(dstr);
4601             if (do_utf8)
4602                 (void)SvUTF8_on(dstr);
4603             XPUSHs(dstr);
4604             if (rx->nparens) {
4605                 for (i = 1; i <= (I32)rx->nparens; i++) {
4606                     s = rx->startp[i] + orig;
4607                     m = rx->endp[i] + orig;
4608
4609                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4610                        parens that didn't match -- they should be set to
4611                        undef, not the empty string */
4612                     if (m >= orig && s >= orig) {
4613                         dstr = NEWSV(33, m-s);
4614                         sv_setpvn(dstr, s, m-s);
4615                     }
4616                     else
4617                         dstr = &PL_sv_undef;  /* undef, not "" */
4618                     if (make_mortal)
4619                         sv_2mortal(dstr);
4620                     if (do_utf8)
4621                         (void)SvUTF8_on(dstr);
4622                     XPUSHs(dstr);
4623                 }
4624             }
4625             s = rx->endp[0] + orig;
4626         }
4627     }
4628
4629     LEAVE_SCOPE(oldsave);
4630     iters = (SP - PL_stack_base) - base;
4631     if (iters > maxiters)
4632         DIE(aTHX_ "Split loop");
4633
4634     /* keep field after final delim? */
4635     if (s < strend || (iters && origlimit)) {
4636         STRLEN l = strend - s;
4637         dstr = NEWSV(34, l);
4638         sv_setpvn(dstr, s, l);
4639         if (make_mortal)
4640             sv_2mortal(dstr);
4641         if (do_utf8)
4642             (void)SvUTF8_on(dstr);
4643         XPUSHs(dstr);
4644         iters++;
4645     }
4646     else if (!origlimit) {
4647         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4648             if (TOPs && !make_mortal)
4649                 sv_2mortal(TOPs);
4650             iters--;
4651             SP--;
4652         }
4653     }
4654
4655     if (realarray) {
4656         if (!mg) {
4657             SWITCHSTACK(ary, oldstack);
4658             PL_curstackinfo->si_stack = oldstack;
4659             if (SvSMAGICAL(ary)) {
4660                 PUTBACK;
4661                 mg_set((SV*)ary);
4662                 SPAGAIN;
4663             }
4664             if (gimme == G_ARRAY) {
4665                 EXTEND(SP, iters);
4666                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4667                 SP += iters;
4668                 RETURN;
4669             }
4670         }
4671         else {
4672             PUTBACK;
4673             ENTER;
4674             call_method("PUSH",G_SCALAR|G_DISCARD);
4675             LEAVE;
4676             SPAGAIN;
4677             if (gimme == G_ARRAY) {
4678                 /* EXTEND should not be needed - we just popped them */
4679                 EXTEND(SP, iters);
4680                 for (i=0; i < iters; i++) {
4681                     SV **svp = av_fetch(ary, i, FALSE);
4682                     PUSHs((svp) ? *svp : &PL_sv_undef);
4683                 }
4684                 RETURN;
4685             }
4686         }
4687     }
4688     else {
4689         if (gimme == G_ARRAY)
4690             RETURN;
4691     }
4692
4693     GETTARGET;
4694     PUSHi(iters);
4695     RETURN;
4696 }
4697
4698 PP(pp_lock)
4699 {
4700     dSP;
4701     dTOPss;
4702     SV *retsv = sv;
4703     SvLOCK(sv);
4704     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4705         || SvTYPE(retsv) == SVt_PVCV) {
4706         retsv = refto(retsv);
4707     }
4708     SETs(retsv);
4709     RETURN;
4710 }
4711
4712 PP(pp_threadsv)
4713 {
4714     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4715 }