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