pp.c

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