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 (SvNIOKp(left) || SvNIOKp(right)) {
2204         if (PL_op->op_private & HINT_INTEGER) {
2205           IV i = SvIV(left) & SvIV(right);
2206           SETi(i);
2207         }
2208         else {
2209           UV u = SvUV(left) & SvUV(right);
2210           SETu(u);
2211         }
2212       }
2213       else {
2214         do_vop(PL_op->op_type, TARG, left, right);
2215         SETTARG;
2216       }
2217       RETURN;
2218     }
2219 }
2220
2221 PP(pp_bit_xor)
2222 {
2223     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2224     {
2225       dPOPTOPssrl;
2226       if (SvNIOKp(left) || SvNIOKp(right)) {
2227         if (PL_op->op_private & HINT_INTEGER) {
2228           IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2229           SETi(i);
2230         }
2231         else {
2232           UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2233           SETu(u);
2234         }
2235       }
2236       else {
2237         do_vop(PL_op->op_type, TARG, left, right);
2238         SETTARG;
2239       }
2240       RETURN;
2241     }
2242 }
2243
2244 PP(pp_bit_or)
2245 {
2246     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2247     {
2248       dPOPTOPssrl;
2249       if (SvNIOKp(left) || SvNIOKp(right)) {
2250         if (PL_op->op_private & HINT_INTEGER) {
2251           IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2252           SETi(i);
2253         }
2254         else {
2255           UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2256           SETu(u);
2257         }
2258       }
2259       else {
2260         do_vop(PL_op->op_type, TARG, left, right);
2261         SETTARG;
2262       }
2263       RETURN;
2264     }
2265 }
2266
2267 PP(pp_negate)
2268 {
2269     dSP; dTARGET; tryAMAGICun(neg);
2270     {
2271         dTOPss;
2272         int flags = SvFLAGS(sv);
2273         if (SvGMAGICAL(sv))
2274             mg_get(sv);
2275         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2276             /* It's publicly an integer, or privately an integer-not-float */
2277         oops_its_an_int:
2278             if (SvIsUV(sv)) {
2279                 if (SvIVX(sv) == IV_MIN) {
2280                     /* 2s complement assumption. */
2281                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2282                     RETURN;
2283                 }
2284                 else if (SvUVX(sv) <= IV_MAX) {
2285                     SETi(-SvIVX(sv));
2286                     RETURN;
2287                 }
2288             }
2289             else if (SvIVX(sv) != IV_MIN) {
2290                 SETi(-SvIVX(sv));
2291                 RETURN;
2292             }
2293 #ifdef PERL_PRESERVE_IVUV
2294             else {
2295                 SETu((UV)IV_MIN);
2296                 RETURN;
2297             }
2298 #endif
2299         }
2300         if (SvNIOKp(sv))
2301             SETn(-SvNV(sv));
2302         else if (SvPOKp(sv)) {
2303             STRLEN len;
2304             char *s = SvPV(sv, len);
2305             if (isIDFIRST(*s)) {
2306                 sv_setpvn(TARG, "-", 1);
2307                 sv_catsv(TARG, sv);
2308             }
2309             else if (*s == '+' || *s == '-') {
2310                 sv_setsv(TARG, sv);
2311                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2312             }
2313             else if (DO_UTF8(sv)) {
2314                 SvIV_please(sv);
2315                 if (SvIOK(sv))
2316                     goto oops_its_an_int;
2317                 if (SvNOK(sv))
2318                     sv_setnv(TARG, -SvNV(sv));
2319                 else {
2320                     sv_setpvn(TARG, "-", 1);
2321                     sv_catsv(TARG, sv);
2322                 }
2323             }
2324             else {
2325                 SvIV_please(sv);
2326                 if (SvIOK(sv))
2327                   goto oops_its_an_int;
2328                 sv_setnv(TARG, -SvNV(sv));
2329             }
2330             SETTARG;
2331         }
2332         else
2333             SETn(-SvNV(sv));
2334     }
2335     RETURN;
2336 }
2337
2338 PP(pp_not)
2339 {
2340     dSP; tryAMAGICunSET(not);
2341     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2342     return NORMAL;
2343 }
2344
2345 PP(pp_complement)
2346 {
2347     dSP; dTARGET; tryAMAGICun(compl);
2348     {
2349       dTOPss;
2350       if (SvNIOKp(sv)) {
2351         if (PL_op->op_private & HINT_INTEGER) {
2352           IV i = ~SvIV(sv);
2353           SETi(i);
2354         }
2355         else {
2356           UV u = ~SvUV(sv);
2357           SETu(u);
2358         }
2359       }
2360       else {
2361         register U8 *tmps;
2362         register I32 anum;
2363         STRLEN len;
2364
2365         SvSetSV(TARG, sv);
2366         tmps = (U8*)SvPV_force(TARG, len);
2367         anum = len;
2368         if (SvUTF8(TARG)) {
2369           /* Calculate exact length, let's not estimate. */
2370           STRLEN targlen = 0;
2371           U8 *result;
2372           U8 *send;
2373           STRLEN l;
2374           UV nchar = 0;
2375           UV nwide = 0;
2376
2377           send = tmps + len;
2378           while (tmps < send) {
2379             UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2380             tmps += UTF8SKIP(tmps);
2381             targlen += UNISKIP(~c);
2382             nchar++;
2383             if (c > 0xff)
2384                 nwide++;
2385           }
2386
2387           /* Now rewind strings and write them. */
2388           tmps -= len;
2389
2390           if (nwide) {
2391               Newz(0, result, targlen + 1, U8);
2392               while (tmps < send) {
2393                   UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2394                   tmps += UTF8SKIP(tmps);
2395                   result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2396               }
2397               *result = '\0';
2398               result -= targlen;
2399               sv_setpvn(TARG, (char*)result, targlen);
2400               SvUTF8_on(TARG);
2401           }
2402           else {
2403               Newz(0, result, nchar + 1, U8);
2404               while (tmps < send) {
2405                   U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2406                   tmps += UTF8SKIP(tmps);
2407                   *result++ = ~c;
2408               }
2409               *result = '\0';
2410               result -= nchar;
2411               sv_setpvn(TARG, (char*)result, nchar);
2412           }
2413           Safefree(result);
2414           SETs(TARG);
2415           RETURN;
2416         }
2417 #ifdef LIBERAL
2418         {
2419             register long *tmpl;
2420             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2421                 *tmps = ~*tmps;
2422             tmpl = (long*)tmps;
2423             for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2424                 *tmpl = ~*tmpl;
2425             tmps = (U8*)tmpl;
2426         }
2427 #endif
2428         for ( ; anum > 0; anum--, tmps++)
2429             *tmps = ~*tmps;
2430
2431         SETs(TARG);
2432       }
2433       RETURN;
2434     }
2435 }
2436
2437 /* integer versions of some of the above */
2438
2439 PP(pp_i_multiply)
2440 {
2441     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2442     {
2443       dPOPTOPiirl;
2444       SETi( left * right );
2445       RETURN;
2446     }
2447 }
2448
2449 PP(pp_i_divide)
2450 {
2451     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2452     {
2453       dPOPiv;
2454       if (value == 0)
2455         DIE(aTHX_ "Illegal division by zero");
2456       value = POPi / value;
2457       PUSHi( value );
2458       RETURN;
2459     }
2460 }
2461
2462 STATIC
2463 PP(pp_i_modulo_0)
2464 {
2465      /* This is the vanilla old i_modulo. */
2466      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2467      {
2468           dPOPTOPiirl;
2469           if (!right)
2470                DIE(aTHX_ "Illegal modulus zero");
2471           SETi( left % right );
2472           RETURN;
2473      }
2474 }
2475
2476 #if defined(__GLIBC__) && IVSIZE == 8
2477 STATIC
2478 PP(pp_i_modulo_1)
2479 {
2480      /* This is the i_modulo with the workaround for the _moddi3 bug
2481       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2482       * See below for pp_i_modulo. */
2483      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2484      {
2485           dPOPTOPiirl;
2486           if (!right)
2487                DIE(aTHX_ "Illegal modulus zero");
2488           SETi( left % PERL_ABS(right) );
2489           RETURN;
2490      }
2491 }
2492 #endif
2493
2494 PP(pp_i_modulo)
2495 {
2496      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2497      {
2498           dPOPTOPiirl;
2499           if (!right)
2500                DIE(aTHX_ "Illegal modulus zero");
2501           /* The assumption is to use hereafter the old vanilla version... */
2502           PL_op->op_ppaddr =
2503                PL_ppaddr[OP_I_MODULO] =
2504                    &Perl_pp_i_modulo_0;
2505           /* .. but if we have glibc, we might have a buggy _moddi3
2506            * (at least glicb 2.2.5 is known to have this bug), in other
2507            * words our integer modulus with negative quad as the second
2508            * argument might be broken.  Test for this and re-patch the
2509            * opcode dispatch table if that is the case, remembering to
2510            * also apply the workaround so that this first round works
2511            * right, too.  See [perl #9402] for more information. */
2512 #if defined(__GLIBC__) && IVSIZE == 8
2513           {
2514                IV l =   3;
2515                IV r = -10;
2516                /* Cannot do this check with inlined IV constants since
2517                 * that seems to work correctly even with the buggy glibc. */
2518                if (l % r == -3) {
2519                     /* Yikes, we have the bug.
2520                      * Patch in the workaround version. */
2521                     PL_op->op_ppaddr =
2522                          PL_ppaddr[OP_I_MODULO] =
2523                              &Perl_pp_i_modulo_1;
2524                     /* Make certain we work right this time, too. */
2525                     right = PERL_ABS(right);
2526                }
2527           }
2528 #endif
2529           SETi( left % right );
2530           RETURN;
2531      }
2532 }
2533
2534 PP(pp_i_add)
2535 {
2536     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2537     {
2538       dPOPTOPiirl_ul;
2539       SETi( left + right );
2540       RETURN;
2541     }
2542 }
2543
2544 PP(pp_i_subtract)
2545 {
2546     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2547     {
2548       dPOPTOPiirl_ul;
2549       SETi( left - right );
2550       RETURN;
2551     }
2552 }
2553
2554 PP(pp_i_lt)
2555 {
2556     dSP; tryAMAGICbinSET(lt,0);
2557     {
2558       dPOPTOPiirl;
2559       SETs(boolSV(left < right));
2560       RETURN;
2561     }
2562 }
2563
2564 PP(pp_i_gt)
2565 {
2566     dSP; tryAMAGICbinSET(gt,0);
2567     {
2568       dPOPTOPiirl;
2569       SETs(boolSV(left > right));
2570       RETURN;
2571     }
2572 }
2573
2574 PP(pp_i_le)
2575 {
2576     dSP; tryAMAGICbinSET(le,0);
2577     {
2578       dPOPTOPiirl;
2579       SETs(boolSV(left <= right));
2580       RETURN;
2581     }
2582 }
2583
2584 PP(pp_i_ge)
2585 {
2586     dSP; tryAMAGICbinSET(ge,0);
2587     {
2588       dPOPTOPiirl;
2589       SETs(boolSV(left >= right));
2590       RETURN;
2591     }
2592 }
2593
2594 PP(pp_i_eq)
2595 {
2596     dSP; tryAMAGICbinSET(eq,0);
2597     {
2598       dPOPTOPiirl;
2599       SETs(boolSV(left == right));
2600       RETURN;
2601     }
2602 }
2603
2604 PP(pp_i_ne)
2605 {
2606     dSP; tryAMAGICbinSET(ne,0);
2607     {
2608       dPOPTOPiirl;
2609       SETs(boolSV(left != right));
2610       RETURN;
2611     }
2612 }
2613
2614 PP(pp_i_ncmp)
2615 {
2616     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2617     {
2618       dPOPTOPiirl;
2619       I32 value;
2620
2621       if (left > right)
2622         value = 1;
2623       else if (left < right)
2624         value = -1;
2625       else
2626         value = 0;
2627       SETi(value);
2628       RETURN;
2629     }
2630 }
2631
2632 PP(pp_i_negate)
2633 {
2634     dSP; dTARGET; tryAMAGICun(neg);
2635     SETi(-TOPi);
2636     RETURN;
2637 }
2638
2639 /* High falutin' math. */
2640
2641 PP(pp_atan2)
2642 {
2643     dSP; dTARGET; tryAMAGICbin(atan2,0);
2644     {
2645       dPOPTOPnnrl;
2646       SETn(Perl_atan2(left, right));
2647       RETURN;
2648     }
2649 }
2650
2651 PP(pp_sin)
2652 {
2653     dSP; dTARGET; tryAMAGICun(sin);
2654     {
2655       NV value;
2656       value = POPn;
2657       value = Perl_sin(value);
2658       XPUSHn(value);
2659       RETURN;
2660     }
2661 }
2662
2663 PP(pp_cos)
2664 {
2665     dSP; dTARGET; tryAMAGICun(cos);
2666     {
2667       NV value;
2668       value = POPn;
2669       value = Perl_cos(value);
2670       XPUSHn(value);
2671       RETURN;
2672     }
2673 }
2674
2675 /* Support Configure command-line overrides for rand() functions.
2676    After 5.005, perhaps we should replace this by Configure support
2677    for drand48(), random(), or rand().  For 5.005, though, maintain
2678    compatibility by calling rand() but allow the user to override it.
2679    See INSTALL for details.  --Andy Dougherty  15 July 1998
2680 */
2681 /* Now it's after 5.005, and Configure supports drand48() and random(),
2682    in addition to rand().  So the overrides should not be needed any more.
2683    --Jarkko Hietaniemi  27 September 1998
2684  */
2685
2686 #ifndef HAS_DRAND48_PROTO
2687 extern double drand48 (void);
2688 #endif
2689
2690 PP(pp_rand)
2691 {
2692     dSP; dTARGET;
2693     NV value;
2694     if (MAXARG < 1)
2695         value = 1.0;
2696     else
2697         value = POPn;
2698     if (value == 0.0)
2699         value = 1.0;
2700     if (!PL_srand_called) {
2701         (void)seedDrand01((Rand_seed_t)seed());
2702         PL_srand_called = TRUE;
2703     }
2704     value *= Drand01();
2705     XPUSHn(value);
2706     RETURN;
2707 }
2708
2709 PP(pp_srand)
2710 {
2711     dSP;
2712     UV anum;
2713     if (MAXARG < 1)
2714         anum = seed();
2715     else
2716         anum = POPu;
2717     (void)seedDrand01((Rand_seed_t)anum);
2718     PL_srand_called = TRUE;
2719     EXTEND(SP, 1);
2720     RETPUSHYES;
2721 }
2722
2723 PP(pp_exp)
2724 {
2725     dSP; dTARGET; tryAMAGICun(exp);
2726     {
2727       NV value;
2728       value = POPn;
2729       value = Perl_exp(value);
2730       XPUSHn(value);
2731       RETURN;
2732     }
2733 }
2734
2735 PP(pp_log)
2736 {
2737     dSP; dTARGET; tryAMAGICun(log);
2738     {
2739       NV value;
2740       value = POPn;
2741       if (value <= 0.0) {
2742         SET_NUMERIC_STANDARD();
2743         DIE(aTHX_ "Can't take log of %"NVgf, value);
2744       }
2745       value = Perl_log(value);
2746       XPUSHn(value);
2747       RETURN;
2748     }
2749 }
2750
2751 PP(pp_sqrt)
2752 {
2753     dSP; dTARGET; tryAMAGICun(sqrt);
2754     {
2755       NV value;
2756       value = POPn;
2757       if (value < 0.0) {
2758         SET_NUMERIC_STANDARD();
2759         DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2760       }
2761       value = Perl_sqrt(value);
2762       XPUSHn(value);
2763       RETURN;
2764     }
2765 }
2766
2767 PP(pp_int)
2768 {
2769     dSP; dTARGET; tryAMAGICun(int);
2770     {
2771       NV value;
2772       IV iv = TOPi; /* attempt to convert to IV if possible. */
2773       /* XXX it's arguable that compiler casting to IV might be subtly
2774          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2775          else preferring IV has introduced a subtle behaviour change bug. OTOH
2776          relying on floating point to be accurate is a bug.  */
2777
2778       if (SvIOK(TOPs)) {
2779         if (SvIsUV(TOPs)) {
2780             UV uv = TOPu;
2781             SETu(uv);
2782         } else
2783             SETi(iv);
2784       } else {
2785           value = TOPn;
2786           if (value >= 0.0) {
2787               if (value < (NV)UV_MAX + 0.5) {
2788                   SETu(U_V(value));
2789               } else {
2790                   SETn(Perl_floor(value));
2791               }
2792           }
2793           else {
2794               if (value > (NV)IV_MIN - 0.5) {
2795                   SETi(I_V(value));
2796               } else {
2797                   SETn(Perl_ceil(value));
2798               }
2799           }
2800       }
2801     }
2802     RETURN;
2803 }
2804
2805 PP(pp_abs)
2806 {
2807     dSP; dTARGET; tryAMAGICun(abs);
2808     {
2809       /* This will cache the NV value if string isn't actually integer  */
2810       IV iv = TOPi;
2811
2812       if (SvIOK(TOPs)) {
2813         /* IVX is precise  */
2814         if (SvIsUV(TOPs)) {
2815           SETu(TOPu);   /* force it to be numeric only */
2816         } else {
2817           if (iv >= 0) {
2818             SETi(iv);
2819           } else {
2820             if (iv != IV_MIN) {
2821               SETi(-iv);
2822             } else {
2823               /* 2s complement assumption. Also, not really needed as
2824                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2825               SETu(IV_MIN);
2826             }
2827           }
2828         }
2829       } else{
2830         NV value = TOPn;
2831         if (value < 0.0)
2832           value = -value;
2833         SETn(value);
2834       }
2835     }
2836     RETURN;
2837 }
2838
2839
2840 PP(pp_hex)
2841 {
2842     dSP; dTARGET;
2843     char *tmps;
2844     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2845     STRLEN len;
2846     NV result_nv;
2847     UV result_uv;
2848     SV* sv = POPs;
2849
2850     tmps = (SvPVx(sv, len));
2851     if (DO_UTF8(sv)) {
2852          /* If Unicode, try to downgrade
2853           * If not possible, croak. */
2854          SV* tsv = sv_2mortal(newSVsv(sv));
2855
2856          SvUTF8_on(tsv);
2857          sv_utf8_downgrade(tsv, FALSE);
2858          tmps = SvPVX(tsv);
2859     }
2860     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2861     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2862         XPUSHn(result_nv);
2863     }
2864     else {
2865         XPUSHu(result_uv);
2866     }
2867     RETURN;
2868 }
2869
2870 PP(pp_oct)
2871 {
2872     dSP; dTARGET;
2873     char *tmps;
2874     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2875     STRLEN len;
2876     NV result_nv;
2877     UV result_uv;
2878     SV* sv = POPs;
2879
2880     tmps = (SvPVx(sv, len));
2881     if (DO_UTF8(sv)) {
2882          /* If Unicode, try to downgrade
2883           * If not possible, croak. */
2884          SV* tsv = sv_2mortal(newSVsv(sv));
2885
2886          SvUTF8_on(tsv);
2887          sv_utf8_downgrade(tsv, FALSE);
2888          tmps = SvPVX(tsv);
2889     }
2890     while (*tmps && len && isSPACE(*tmps))
2891         tmps++, len--;
2892     if (*tmps == '0')
2893         tmps++, len--;
2894     if (*tmps == 'x')
2895         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2896     else if (*tmps == 'b')
2897         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2898     else
2899         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2900
2901     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2902         XPUSHn(result_nv);
2903     }
2904     else {
2905         XPUSHu(result_uv);
2906     }
2907     RETURN;
2908 }
2909
2910 /* String stuff. */
2911
2912 PP(pp_length)
2913 {
2914     dSP; dTARGET;
2915     SV *sv = TOPs;
2916
2917     if (DO_UTF8(sv))
2918         SETi(sv_len_utf8(sv));
2919     else
2920         SETi(sv_len(sv));
2921     RETURN;
2922 }
2923
2924 PP(pp_substr)
2925 {
2926     dSP; dTARGET;
2927     SV *sv;
2928     I32 len = 0;
2929     STRLEN curlen;
2930     STRLEN utf8_curlen;
2931     I32 pos;
2932     I32 rem;
2933     I32 fail;
2934     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2935     char *tmps;
2936     I32 arybase = PL_curcop->cop_arybase;
2937     SV *repl_sv = NULL;
2938     char *repl = 0;
2939     STRLEN repl_len;
2940     int num_args = PL_op->op_private & 7;
2941     bool repl_need_utf8_upgrade = FALSE;
2942     bool repl_is_utf8 = FALSE;
2943
2944     SvTAINTED_off(TARG);                        /* decontaminate */
2945     SvUTF8_off(TARG);                           /* decontaminate */
2946     if (num_args > 2) {
2947         if (num_args > 3) {
2948             repl_sv = POPs;
2949             repl = SvPV(repl_sv, repl_len);
2950             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2951         }
2952         len = POPi;
2953     }
2954     pos = POPi;
2955     sv = POPs;
2956     PUTBACK;
2957     if (repl_sv) {
2958         if (repl_is_utf8) {
2959             if (!DO_UTF8(sv))
2960                 sv_utf8_upgrade(sv);
2961         }
2962         else if (DO_UTF8(sv))
2963             repl_need_utf8_upgrade = TRUE;
2964     }
2965     tmps = SvPV(sv, curlen);
2966     if (DO_UTF8(sv)) {
2967         utf8_curlen = sv_len_utf8(sv);
2968         if (utf8_curlen == curlen)
2969             utf8_curlen = 0;
2970         else
2971             curlen = utf8_curlen;
2972     }
2973     else
2974         utf8_curlen = 0;
2975
2976     if (pos >= arybase) {
2977         pos -= arybase;
2978         rem = curlen-pos;
2979         fail = rem;
2980         if (num_args > 2) {
2981             if (len < 0) {
2982                 rem += len;
2983                 if (rem < 0)
2984                     rem = 0;
2985             }
2986             else if (rem > len)
2987                      rem = len;
2988         }
2989     }
2990     else {
2991         pos += curlen;
2992         if (num_args < 3)
2993             rem = curlen;
2994         else if (len >= 0) {
2995             rem = pos+len;
2996             if (rem > (I32)curlen)
2997                 rem = curlen;
2998         }
2999         else {
3000             rem = curlen+len;
3001             if (rem < pos)
3002                 rem = pos;
3003         }
3004         if (pos < 0)
3005             pos = 0;
3006         fail = rem;
3007         rem -= pos;
3008     }
3009     if (fail < 0) {
3010         if (lvalue || repl)
3011             Perl_croak(aTHX_ "substr outside of string");
3012         if (ckWARN(WARN_SUBSTR))
3013             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3014         RETPUSHUNDEF;
3015     }
3016     else {
3017         I32 upos = pos;
3018         I32 urem = rem;
3019         if (utf8_curlen)
3020             sv_pos_u2b(sv, &pos, &rem);
3021         tmps += pos;
3022         sv_setpvn(TARG, tmps, rem);
3023 #ifdef USE_LOCALE_COLLATE
3024         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3025 #endif
3026         if (utf8_curlen)
3027             SvUTF8_on(TARG);
3028         if (repl) {
3029             SV* repl_sv_copy = NULL;
3030
3031             if (repl_need_utf8_upgrade) {
3032                 repl_sv_copy = newSVsv(repl_sv);
3033                 sv_utf8_upgrade(repl_sv_copy);
3034                 repl = SvPV(repl_sv_copy, repl_len);
3035                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3036             }
3037             sv_insert(sv, pos, rem, repl, repl_len);
3038             if (repl_is_utf8)
3039                 SvUTF8_on(sv);
3040             if (repl_sv_copy)
3041                 SvREFCNT_dec(repl_sv_copy);
3042         }
3043         else if (lvalue) {              /* it's an lvalue! */
3044             if (!SvGMAGICAL(sv)) {
3045                 if (SvROK(sv)) {
3046                     STRLEN n_a;
3047                     SvPV_force(sv,n_a);
3048                     if (ckWARN(WARN_SUBSTR))
3049                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3050                                 "Attempt to use reference as lvalue in substr");
3051                 }
3052                 if (SvOK(sv))           /* is it defined ? */
3053                     (void)SvPOK_only_UTF8(sv);
3054                 else
3055                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3056             }
3057
3058             if (SvREFCNT(TARG) > 1)     /* don't share the TARG (#20933) */
3059                 TARG = sv_newmortal();
3060             if (SvTYPE(TARG) < SVt_PVLV) {
3061                 sv_upgrade(TARG, SVt_PVLV);
3062                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3063             }
3064             else
3065                 (void)SvOK_off(TARG);
3066
3067             LvTYPE(TARG) = 'x';
3068             if (LvTARG(TARG) != sv) {
3069                 if (LvTARG(TARG))
3070                     SvREFCNT_dec(LvTARG(TARG));
3071                 LvTARG(TARG) = SvREFCNT_inc(sv);
3072             }
3073             LvTARGOFF(TARG) = upos;
3074             LvTARGLEN(TARG) = urem;
3075         }
3076     }
3077     SPAGAIN;
3078     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3079     RETURN;
3080 }
3081
3082 PP(pp_vec)
3083 {
3084     dSP; dTARGET;
3085     register IV size   = POPi;
3086     register IV offset = POPi;
3087     register SV *src = POPs;
3088     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3089
3090     SvTAINTED_off(TARG);                /* decontaminate */
3091     if (lvalue) {                       /* it's an lvalue! */
3092         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3093             TARG = sv_newmortal();
3094         if (SvTYPE(TARG) < SVt_PVLV) {
3095             sv_upgrade(TARG, SVt_PVLV);
3096             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3097         }
3098         LvTYPE(TARG) = 'v';
3099         if (LvTARG(TARG) != src) {
3100             if (LvTARG(TARG))
3101                 SvREFCNT_dec(LvTARG(TARG));
3102             LvTARG(TARG) = SvREFCNT_inc(src);
3103         }
3104         LvTARGOFF(TARG) = offset;
3105         LvTARGLEN(TARG) = size;
3106     }
3107
3108     sv_setuv(TARG, do_vecget(src, offset, size));
3109     PUSHs(TARG);
3110     RETURN;
3111 }
3112
3113 PP(pp_index)
3114 {
3115     dSP; dTARGET;
3116     SV *big;
3117     SV *little;
3118     I32 offset;
3119     I32 retval;
3120     char *tmps;
3121     char *tmps2;
3122     STRLEN biglen;
3123     I32 arybase = PL_curcop->cop_arybase;
3124
3125     if (MAXARG < 3)
3126         offset = 0;
3127     else
3128         offset = POPi - arybase;
3129     little = POPs;
3130     big = POPs;
3131     tmps = SvPV(big, biglen);
3132     if (offset > 0 && DO_UTF8(big))
3133         sv_pos_u2b(big, &offset, 0);
3134     if (offset < 0)
3135         offset = 0;
3136     else if (offset > (I32)biglen)
3137         offset = biglen;
3138     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3139       (unsigned char*)tmps + biglen, little, 0)))
3140         retval = -1;
3141     else
3142         retval = tmps2 - tmps;
3143     if (retval > 0 && DO_UTF8(big))
3144         sv_pos_b2u(big, &retval);
3145     PUSHi(retval + arybase);
3146     RETURN;
3147 }
3148
3149 PP(pp_rindex)
3150 {
3151     dSP; dTARGET;
3152     SV *big;
3153     SV *little;
3154     STRLEN blen;
3155     STRLEN llen;
3156     I32 offset;
3157     I32 retval;
3158     char *tmps;
3159     char *tmps2;
3160     I32 arybase = PL_curcop->cop_arybase;
3161
3162     if (MAXARG >= 3)
3163         offset = POPi;
3164     little = POPs;
3165     big = POPs;
3166     tmps2 = SvPV(little, llen);
3167     tmps = SvPV(big, blen);
3168     if (MAXARG < 3)
3169         offset = blen;
3170     else {
3171         if (offset > 0 && DO_UTF8(big))
3172             sv_pos_u2b(big, &offset, 0);
3173         offset = offset - arybase + llen;
3174     }
3175     if (offset < 0)
3176         offset = 0;
3177     else if (offset > (I32)blen)
3178         offset = blen;
3179     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3180                           tmps2, tmps2 + llen)))
3181         retval = -1;
3182     else
3183         retval = tmps2 - tmps;
3184     if (retval > 0 && DO_UTF8(big))
3185         sv_pos_b2u(big, &retval);
3186     PUSHi(retval + arybase);
3187     RETURN;
3188 }
3189
3190 PP(pp_sprintf)
3191 {
3192     dSP; dMARK; dORIGMARK; dTARGET;
3193     do_sprintf(TARG, SP-MARK, MARK+1);
3194     TAINT_IF(SvTAINTED(TARG));
3195     if (DO_UTF8(*(MARK+1)))
3196         SvUTF8_on(TARG);
3197     SP = ORIGMARK;
3198     PUSHTARG;
3199     RETURN;
3200 }
3201
3202 PP(pp_ord)
3203 {
3204     dSP; dTARGET;
3205     SV *argsv = POPs;
3206     STRLEN len;
3207     U8 *s = (U8*)SvPVx(argsv, len);
3208     SV *tmpsv;
3209
3210     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3211         tmpsv = sv_2mortal(newSVsv(argsv));
3212         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3213         argsv = tmpsv;
3214     }
3215
3216     XPUSHu(DO_UTF8(argsv) ?
3217            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3218            (*s & 0xff));
3219
3220     RETURN;
3221 }
3222
3223 PP(pp_chr)
3224 {
3225     dSP; dTARGET;
3226     char *tmps;
3227     UV value = POPu;
3228
3229     (void)SvUPGRADE(TARG,SVt_PV);
3230
3231     if (value > 255 && !IN_BYTES) {
3232         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3233         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3234         SvCUR_set(TARG, tmps - SvPVX(TARG));
3235         *tmps = '\0';
3236         (void)SvPOK_only(TARG);
3237         SvUTF8_on(TARG);
3238         XPUSHs(TARG);
3239         RETURN;
3240     }
3241
3242     SvGROW(TARG,2);
3243     SvCUR_set(TARG, 1);
3244     tmps = SvPVX(TARG);
3245     *tmps++ = (char)value;
3246     *tmps = '\0';
3247     (void)SvPOK_only(TARG);
3248     if (PL_encoding && !IN_BYTES) {
3249         sv_recode_to_utf8(TARG, PL_encoding);
3250         tmps = SvPVX(TARG);
3251         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3252             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3253             SvGROW(TARG, 3);
3254             tmps = SvPVX(TARG);
3255             SvCUR_set(TARG, 2);
3256             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3257             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3258             *tmps = '\0';
3259             SvUTF8_on(TARG);
3260         }
3261     }
3262     XPUSHs(TARG);
3263     RETURN;
3264 }
3265
3266 PP(pp_crypt)
3267 {
3268     dSP; dTARGET;
3269 #ifdef HAS_CRYPT
3270     dPOPTOPssrl;
3271     STRLEN n_a;
3272     STRLEN len;
3273     char *tmps = SvPV(left, len);
3274
3275     if (DO_UTF8(left)) {
3276          /* If Unicode, try to downgrade.
3277           * If not possible, croak.
3278           * Yes, we made this up.  */
3279          SV* tsv = sv_2mortal(newSVsv(left));
3280
3281          SvUTF8_on(tsv);
3282          sv_utf8_downgrade(tsv, FALSE);
3283          tmps = SvPVX(tsv);
3284     }
3285 #   ifdef USE_ITHREADS
3286 #     ifdef HAS_CRYPT_R
3287     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3288       /* This should be threadsafe because in ithreads there is only
3289        * one thread per interpreter.  If this would not be true,
3290        * we would need a mutex to protect this malloc. */
3291         PL_reentrant_buffer->_crypt_struct_buffer =
3292           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3293 #if defined(__GLIBC__) || defined(__EMX__)
3294         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3295             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3296             /* work around glibc-2.2.5 bug */
3297             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3298         }
3299 #endif
3300     }
3301 #     endif /* HAS_CRYPT_R */
3302 #   endif /* USE_ITHREADS */
3303 #   ifdef FCRYPT
3304     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3305 #   else
3306     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3307 #   endif
3308     SETs(TARG);
3309     RETURN;
3310 #else
3311     DIE(aTHX_
3312       "The crypt() function is unimplemented due to excessive paranoia.");
3313 #endif
3314 }
3315
3316 PP(pp_ucfirst)
3317 {
3318     dSP;
3319     SV *sv = TOPs;
3320     register U8 *s;
3321     STRLEN slen;
3322
3323     SvGETMAGIC(sv);
3324     if (DO_UTF8(sv) &&
3325         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3326         UTF8_IS_START(*s)) {
3327         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3328         STRLEN ulen;
3329         STRLEN tculen;
3330
3331         utf8_to_uvchr(s, &ulen);
3332         toTITLE_utf8(s, tmpbuf, &tculen);
3333         utf8_to_uvchr(tmpbuf, 0);
3334
3335         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3336             dTARGET;
3337             /* slen is the byte length of the whole SV.
3338              * ulen is the byte length of the original Unicode character
3339              * stored as UTF-8 at s.
3340              * tculen is the byte length of the freshly titlecased
3341              * Unicode character stored as UTF-8 at tmpbuf.
3342              * We first set the result to be the titlecased character,
3343              * and then append the rest of the SV data. */
3344             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3345             if (slen > ulen)
3346                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3347             SvUTF8_on(TARG);
3348             SETs(TARG);
3349         }
3350         else {
3351             s = (U8*)SvPV_force_nomg(sv, slen);
3352             Copy(tmpbuf, s, tculen, U8);
3353         }
3354     }
3355     else {
3356         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3357             dTARGET;
3358             SvUTF8_off(TARG);                           /* decontaminate */
3359             sv_setsv_nomg(TARG, sv);
3360             sv = TARG;
3361             SETs(sv);
3362         }
3363         s = (U8*)SvPV_force_nomg(sv, slen);
3364         if (*s) {
3365             if (IN_LOCALE_RUNTIME) {
3366                 TAINT;
3367                 SvTAINTED_on(sv);
3368                 *s = toUPPER_LC(*s);
3369             }
3370             else
3371                 *s = toUPPER(*s);
3372         }
3373     }
3374     SvSETMAGIC(sv);
3375     RETURN;
3376 }
3377
3378 PP(pp_lcfirst)
3379 {
3380     dSP;
3381     SV *sv = TOPs;
3382     register U8 *s;
3383     STRLEN slen;
3384
3385     SvGETMAGIC(sv);
3386     if (DO_UTF8(sv) &&
3387         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3388         UTF8_IS_START(*s)) {
3389         STRLEN ulen;
3390         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3391         U8 *tend;
3392         UV uv;
3393
3394         toLOWER_utf8(s, tmpbuf, &ulen);
3395         uv = utf8_to_uvchr(tmpbuf, 0);
3396         tend = uvchr_to_utf8(tmpbuf, uv);
3397
3398         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3399             dTARGET;
3400             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3401             if (slen > ulen)
3402                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3403             SvUTF8_on(TARG);
3404             SETs(TARG);
3405         }
3406         else {
3407             s = (U8*)SvPV_force_nomg(sv, slen);
3408             Copy(tmpbuf, s, ulen, U8);
3409         }
3410     }
3411     else {
3412         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3413             dTARGET;
3414             SvUTF8_off(TARG);                           /* decontaminate */
3415             sv_setsv_nomg(TARG, sv);
3416             sv = TARG;
3417             SETs(sv);
3418         }
3419         s = (U8*)SvPV_force_nomg(sv, slen);
3420         if (*s) {
3421             if (IN_LOCALE_RUNTIME) {
3422                 TAINT;
3423                 SvTAINTED_on(sv);
3424                 *s = toLOWER_LC(*s);
3425             }
3426             else
3427                 *s = toLOWER(*s);
3428         }
3429     }
3430     SvSETMAGIC(sv);
3431     RETURN;
3432 }
3433
3434 PP(pp_uc)
3435 {
3436     dSP;
3437     SV *sv = TOPs;
3438     register U8 *s;
3439     STRLEN len;
3440
3441     SvGETMAGIC(sv);
3442     if (DO_UTF8(sv)) {
3443         dTARGET;
3444         STRLEN ulen;
3445         register U8 *d;
3446         U8 *send;
3447         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3448
3449         s = (U8*)SvPV_nomg(sv,len);
3450         if (!len) {
3451             SvUTF8_off(TARG);                           /* decontaminate */
3452             sv_setpvn(TARG, "", 0);
3453             SETs(TARG);
3454         }
3455         else {
3456             STRLEN nchar = utf8_length(s, s + len);
3457
3458             (void)SvUPGRADE(TARG, SVt_PV);
3459             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3460             (void)SvPOK_only(TARG);
3461             d = (U8*)SvPVX(TARG);
3462             send = s + len;
3463             while (s < send) {
3464                 toUPPER_utf8(s, tmpbuf, &ulen);
3465                 Copy(tmpbuf, d, ulen, U8);
3466                 d += ulen;
3467                 s += UTF8SKIP(s);
3468             }
3469             *d = '\0';
3470             SvUTF8_on(TARG);
3471             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3472             SETs(TARG);
3473         }
3474     }
3475     else {
3476         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3477             dTARGET;
3478             SvUTF8_off(TARG);                           /* decontaminate */
3479             sv_setsv_nomg(TARG, sv);
3480             sv = TARG;
3481             SETs(sv);
3482         }
3483         s = (U8*)SvPV_force_nomg(sv, len);
3484         if (len) {
3485             register U8 *send = s + len;
3486
3487             if (IN_LOCALE_RUNTIME) {
3488                 TAINT;
3489                 SvTAINTED_on(sv);
3490                 for (; s < send; s++)
3491                     *s = toUPPER_LC(*s);
3492             }
3493             else {
3494                 for (; s < send; s++)
3495                     *s = toUPPER(*s);
3496             }
3497         }
3498     }
3499     SvSETMAGIC(sv);
3500     RETURN;
3501 }
3502
3503 PP(pp_lc)
3504 {
3505     dSP;
3506     SV *sv = TOPs;
3507     register U8 *s;
3508     STRLEN len;
3509
3510     SvGETMAGIC(sv);
3511     if (DO_UTF8(sv)) {
3512         dTARGET;
3513         STRLEN ulen;
3514         register U8 *d;
3515         U8 *send;
3516         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3517
3518         s = (U8*)SvPV_nomg(sv,len);
3519         if (!len) {
3520             SvUTF8_off(TARG);                           /* decontaminate */
3521             sv_setpvn(TARG, "", 0);
3522             SETs(TARG);
3523         }
3524         else {
3525             STRLEN nchar = utf8_length(s, s + len);
3526
3527             (void)SvUPGRADE(TARG, SVt_PV);
3528             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3529             (void)SvPOK_only(TARG);
3530             d = (U8*)SvPVX(TARG);
3531             send = s + len;
3532             while (s < send) {
3533                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3534 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3535                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3536                      /*
3537                       * Now if the sigma is NOT followed by
3538                       * /$ignorable_sequence$cased_letter/;
3539                       * and it IS preceded by
3540                       * /$cased_letter$ignorable_sequence/;
3541                       * where $ignorable_sequence is
3542                       * [\x{2010}\x{AD}\p{Mn}]*
3543                       * and $cased_letter is
3544                       * [\p{Ll}\p{Lo}\p{Lt}]
3545                       * then it should be mapped to 0x03C2,
3546                       * (GREEK SMALL LETTER FINAL SIGMA),
3547                       * instead of staying 0x03A3.
3548                       * See lib/unicore/SpecCase.txt.
3549                       */
3550                 }
3551                 Copy(tmpbuf, d, ulen, U8);
3552                 d += ulen;
3553                 s += UTF8SKIP(s);
3554             }
3555             *d = '\0';
3556             SvUTF8_on(TARG);
3557             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3558             SETs(TARG);
3559         }
3560     }
3561     else {
3562         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3563             dTARGET;
3564             SvUTF8_off(TARG);                           /* decontaminate */
3565             sv_setsv_nomg(TARG, sv);
3566             sv = TARG;
3567             SETs(sv);
3568         }
3569
3570         s = (U8*)SvPV_force_nomg(sv, len);
3571         if (len) {
3572             register U8 *send = s + len;
3573
3574             if (IN_LOCALE_RUNTIME) {
3575                 TAINT;
3576                 SvTAINTED_on(sv);
3577                 for (; s < send; s++)
3578                     *s = toLOWER_LC(*s);
3579             }
3580             else {
3581                 for (; s < send; s++)
3582                     *s = toLOWER(*s);
3583             }
3584         }
3585     }
3586     SvSETMAGIC(sv);
3587     RETURN;
3588 }
3589
3590 PP(pp_quotemeta)
3591 {
3592     dSP; dTARGET;
3593     SV *sv = TOPs;
3594     STRLEN len;
3595     register char *s = SvPV(sv,len);
3596     register char *d;
3597
3598     SvUTF8_off(TARG);                           /* decontaminate */
3599     if (len) {
3600         (void)SvUPGRADE(TARG, SVt_PV);
3601         SvGROW(TARG, (len * 2) + 1);
3602         d = SvPVX(TARG);
3603         if (DO_UTF8(sv)) {
3604             while (len) {
3605                 if (UTF8_IS_CONTINUED(*s)) {
3606                     STRLEN ulen = UTF8SKIP(s);
3607                     if (ulen > len)
3608                         ulen = len;
3609                     len -= ulen;
3610                     while (ulen--)
3611                         *d++ = *s++;
3612                 }
3613                 else {
3614                     if (!isALNUM(*s))
3615                         *d++ = '\\';
3616                     *d++ = *s++;
3617                     len--;
3618                 }
3619             }
3620             SvUTF8_on(TARG);
3621         }
3622         else {
3623             while (len--) {
3624                 if (!isALNUM(*s))
3625                     *d++ = '\\';
3626                 *d++ = *s++;
3627             }
3628         }
3629         *d = '\0';
3630         SvCUR_set(TARG, d - SvPVX(TARG));
3631         (void)SvPOK_only_UTF8(TARG);
3632     }
3633     else
3634         sv_setpvn(TARG, s, len);
3635     SETs(TARG);
3636     if (SvSMAGICAL(TARG))
3637         mg_set(TARG);
3638     RETURN;
3639 }
3640
3641 /* Arrays. */
3642
3643 PP(pp_aslice)
3644 {
3645     dSP; dMARK; dORIGMARK;
3646     register SV** svp;
3647     register AV* av = (AV*)POPs;
3648     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3649     I32 arybase = PL_curcop->cop_arybase;
3650     I32 elem;
3651
3652     if (SvTYPE(av) == SVt_PVAV) {
3653         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3654             I32 max = -1;
3655             for (svp = MARK + 1; svp <= SP; svp++) {
3656                 elem = SvIVx(*svp);
3657                 if (elem > max)
3658                     max = elem;
3659             }
3660             if (max > AvMAX(av))
3661                 av_extend(av, max);
3662         }
3663         while (++MARK <= SP) {
3664             elem = SvIVx(*MARK);
3665
3666             if (elem > 0)
3667                 elem -= arybase;
3668             svp = av_fetch(av, elem, lval);
3669             if (lval) {
3670                 if (!svp || *svp == &PL_sv_undef)
3671                     DIE(aTHX_ PL_no_aelem, elem);
3672                 if (PL_op->op_private & OPpLVAL_INTRO)
3673                     save_aelem(av, elem, svp);
3674             }
3675             *MARK = svp ? *svp : &PL_sv_undef;
3676         }
3677     }
3678     if (GIMME != G_ARRAY) {
3679         MARK = ORIGMARK;
3680         *++MARK = *SP;
3681         SP = MARK;
3682     }
3683     RETURN;
3684 }
3685
3686 /* Associative arrays. */
3687
3688 PP(pp_each)
3689 {
3690     dSP;
3691     HV *hash = (HV*)POPs;
3692     HE *entry;
3693     I32 gimme = GIMME_V;
3694
3695     PUTBACK;
3696     /* might clobber stack_sp */
3697     entry = hv_iternext(hash);
3698     SPAGAIN;
3699
3700     EXTEND(SP, 2);
3701     if (entry) {
3702         SV* sv = hv_iterkeysv(entry);
3703         PUSHs(sv);      /* won't clobber stack_sp */
3704         if (gimme == G_ARRAY) {
3705             SV *val;
3706             PUTBACK;
3707             /* might clobber stack_sp */
3708             val = hv_iterval(hash, entry);
3709             SPAGAIN;
3710             PUSHs(val);
3711         }
3712     }
3713     else if (gimme == G_SCALAR)
3714         RETPUSHUNDEF;
3715
3716     RETURN;
3717 }
3718
3719 PP(pp_values)
3720 {
3721     return do_kv();
3722 }
3723
3724 PP(pp_keys)
3725 {
3726     return do_kv();
3727 }
3728
3729 PP(pp_delete)
3730 {
3731     dSP;
3732     I32 gimme = GIMME_V;
3733     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3734     SV *sv;
3735     HV *hv;
3736
3737     if (PL_op->op_private & OPpSLICE) {
3738         dMARK; dORIGMARK;
3739         U32 hvtype;
3740         hv = (HV*)POPs;
3741         hvtype = SvTYPE(hv);
3742         if (hvtype == SVt_PVHV) {                       /* hash element */
3743             while (++MARK <= SP) {
3744                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3745                 *MARK = sv ? sv : &PL_sv_undef;
3746             }
3747         }
3748         else if (hvtype == SVt_PVAV) {                  /* array element */
3749             if (PL_op->op_flags & OPf_SPECIAL) {
3750                 while (++MARK <= SP) {
3751                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3752                     *MARK = sv ? sv : &PL_sv_undef;
3753                 }
3754             }
3755         }
3756         else
3757             DIE(aTHX_ "Not a HASH reference");
3758         if (discard)
3759             SP = ORIGMARK;
3760         else if (gimme == G_SCALAR) {
3761             MARK = ORIGMARK;
3762             *++MARK = *SP;
3763             SP = MARK;
3764         }
3765     }
3766     else {
3767         SV *keysv = POPs;
3768         hv = (HV*)POPs;
3769         if (SvTYPE(hv) == SVt_PVHV)
3770             sv = hv_delete_ent(hv, keysv, discard, 0);
3771         else if (SvTYPE(hv) == SVt_PVAV) {
3772             if (PL_op->op_flags & OPf_SPECIAL)
3773                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3774             else
3775                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3776         }
3777         else
3778             DIE(aTHX_ "Not a HASH reference");
3779         if (!sv)
3780             sv = &PL_sv_undef;
3781         if (!discard)
3782             PUSHs(sv);
3783     }
3784     RETURN;
3785 }
3786
3787 PP(pp_exists)
3788 {
3789     dSP;
3790     SV *tmpsv;
3791     HV *hv;
3792
3793     if (PL_op->op_private & OPpEXISTS_SUB) {
3794         GV *gv;
3795         CV *cv;
3796         SV *sv = POPs;
3797         cv = sv_2cv(sv, &hv, &gv, FALSE);
3798         if (cv)
3799             RETPUSHYES;
3800         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3801             RETPUSHYES;
3802         RETPUSHNO;
3803     }
3804     tmpsv = POPs;
3805     hv = (HV*)POPs;
3806     if (SvTYPE(hv) == SVt_PVHV) {
3807         if (hv_exists_ent(hv, tmpsv, 0))
3808             RETPUSHYES;
3809     }
3810     else if (SvTYPE(hv) == SVt_PVAV) {
3811         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3812             if (av_exists((AV*)hv, SvIV(tmpsv)))
3813                 RETPUSHYES;
3814         }
3815     }
3816     else {
3817         DIE(aTHX_ "Not a HASH reference");
3818     }
3819     RETPUSHNO;
3820 }
3821
3822 PP(pp_hslice)
3823 {
3824     dSP; dMARK; dORIGMARK;
3825     register HV *hv = (HV*)POPs;
3826     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3827     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3828     bool other_magic = FALSE;
3829
3830     if (localizing) {
3831         MAGIC *mg;
3832         HV *stash;
3833
3834         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3835             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3836              /* Try to preserve the existenceness of a tied hash
3837               * element by using EXISTS and DELETE if possible.
3838               * Fallback to FETCH and STORE otherwise */
3839              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3840              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3841              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3842     }
3843
3844     while (++MARK <= SP) {
3845         SV *keysv = *MARK;
3846         SV **svp;
3847         HE *he;
3848         bool preeminent = FALSE;
3849
3850         if (localizing) {
3851             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3852                 hv_exists_ent(hv, keysv, 0);
3853         }
3854
3855         he = hv_fetch_ent(hv, keysv, lval, 0);
3856         svp = he ? &HeVAL(he) : 0;
3857
3858         if (lval) {
3859             if (!svp || *svp == &PL_sv_undef) {
3860                 STRLEN n_a;
3861                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3862             }
3863             if (localizing) {
3864                 if (preeminent)
3865                     save_helem(hv, keysv, svp);
3866                 else {
3867                     STRLEN keylen;
3868                     char *key = SvPV(keysv, keylen);
3869                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3870                 }
3871             }
3872         }
3873         *MARK = svp ? *svp : &PL_sv_undef;
3874     }
3875     if (GIMME != G_ARRAY) {
3876         MARK = ORIGMARK;
3877         *++MARK = *SP;
3878         SP = MARK;
3879     }
3880     RETURN;
3881 }
3882
3883 /* List operators. */
3884
3885 PP(pp_list)
3886 {
3887     dSP; dMARK;
3888     if (GIMME != G_ARRAY) {
3889         if (++MARK <= SP)
3890             *MARK = *SP;                /* unwanted list, return last item */
3891         else
3892             *MARK = &PL_sv_undef;
3893         SP = MARK;
3894     }
3895     RETURN;
3896 }
3897
3898 PP(pp_lslice)
3899 {
3900     dSP;
3901     SV **lastrelem = PL_stack_sp;
3902     SV **lastlelem = PL_stack_base + POPMARK;
3903     SV **firstlelem = PL_stack_base + POPMARK + 1;
3904     register SV **firstrelem = lastlelem + 1;
3905     I32 arybase = PL_curcop->cop_arybase;
3906     I32 lval = PL_op->op_flags & OPf_MOD;
3907     I32 is_something_there = lval;
3908
3909     register I32 max = lastrelem - lastlelem;
3910     register SV **lelem;
3911     register I32 ix;
3912
3913     if (GIMME != G_ARRAY) {
3914         ix = SvIVx(*lastlelem);
3915         if (ix < 0)
3916             ix += max;
3917         else
3918             ix -= arybase;
3919         if (ix < 0 || ix >= max)
3920             *firstlelem = &PL_sv_undef;
3921         else
3922             *firstlelem = firstrelem[ix];
3923         SP = firstlelem;
3924         RETURN;
3925     }
3926
3927     if (max == 0) {
3928         SP = firstlelem - 1;
3929         RETURN;
3930     }
3931
3932     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3933         ix = SvIVx(*lelem);
3934         if (ix < 0)
3935             ix += max;
3936         else
3937             ix -= arybase;
3938         if (ix < 0 || ix >= max)
3939             *lelem = &PL_sv_undef;
3940         else {
3941             is_something_there = TRUE;
3942             if (!(*lelem = firstrelem[ix]))
3943                 *lelem = &PL_sv_undef;
3944         }
3945     }
3946     if (is_something_there)
3947         SP = lastlelem;
3948     else
3949         SP = firstlelem - 1;
3950     RETURN;
3951 }
3952
3953 PP(pp_anonlist)
3954 {
3955     dSP; dMARK; dORIGMARK;
3956     I32 items = SP - MARK;
3957     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3958     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3959     XPUSHs(av);
3960     RETURN;
3961 }
3962
3963 PP(pp_anonhash)
3964 {
3965     dSP; dMARK; dORIGMARK;
3966     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3967
3968     while (MARK < SP) {
3969         SV* key = *++MARK;
3970         SV *val = NEWSV(46, 0);
3971         if (MARK < SP)
3972             sv_setsv(val, *++MARK);
3973         else if (ckWARN(WARN_MISC))
3974             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3975         (void)hv_store_ent(hv,key,val,0);
3976     }
3977     SP = ORIGMARK;
3978     XPUSHs((SV*)hv);
3979     RETURN;
3980 }
3981
3982 PP(pp_splice)
3983 {
3984     dSP; dMARK; dORIGMARK;
3985     register AV *ary = (AV*)*++MARK;
3986     register SV **src;
3987     register SV **dst;
3988     register I32 i;
3989     register I32 offset;
3990     register I32 length;
3991     I32 newlen;
3992     I32 after;
3993     I32 diff;
3994     SV **tmparyval = 0;
3995     MAGIC *mg;
3996
3997     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3998         *MARK-- = SvTIED_obj((SV*)ary, mg);
3999         PUSHMARK(MARK);
4000         PUTBACK;
4001         ENTER;
4002         call_method("SPLICE",GIMME_V);
4003         LEAVE;
4004         SPAGAIN;
4005         RETURN;
4006     }
4007
4008     SP++;
4009
4010     if (++MARK < SP) {
4011         offset = i = SvIVx(*MARK);
4012         if (offset < 0)
4013             offset += AvFILLp(ary) + 1;
4014         else
4015             offset -= PL_curcop->cop_arybase;
4016         if (offset < 0)
4017             DIE(aTHX_ PL_no_aelem, i);
4018         if (++MARK < SP) {
4019             length = SvIVx(*MARK++);
4020             if (length < 0) {
4021                 length += AvFILLp(ary) - offset + 1;
4022                 if (length < 0)
4023                     length = 0;
4024             }
4025         }
4026         else
4027             length = AvMAX(ary) + 1;            /* close enough to infinity */
4028     }
4029     else {
4030         offset = 0;
4031         length = AvMAX(ary) + 1;
4032     }
4033     if (offset > AvFILLp(ary) + 1) {
4034         if (ckWARN(WARN_MISC))
4035             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4036         offset = AvFILLp(ary) + 1;
4037     }
4038     after = AvFILLp(ary) + 1 - (offset + length);
4039     if (after < 0) {                            /* not that much array */
4040         length += after;                        /* offset+length now in array */
4041         after = 0;
4042         if (!AvALLOC(ary))
4043             av_extend(ary, 0);
4044     }
4045
4046     /* At this point, MARK .. SP-1 is our new LIST */
4047
4048     newlen = SP - MARK;
4049     diff = newlen - length;
4050     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4051         av_reify(ary);
4052
4053     if (diff < 0) {                             /* shrinking the area */
4054         if (newlen) {
4055             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4056             Copy(MARK, tmparyval, newlen, SV*);
4057         }
4058
4059         MARK = ORIGMARK + 1;
4060         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4061             MEXTEND(MARK, length);
4062             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4063             if (AvREAL(ary)) {
4064                 EXTEND_MORTAL(length);
4065                 for (i = length, dst = MARK; i; i--) {
4066                     sv_2mortal(*dst);   /* free them eventualy */
4067                     dst++;
4068                 }
4069             }
4070             MARK += length - 1;
4071         }
4072         else {
4073             *MARK = AvARRAY(ary)[offset+length-1];
4074             if (AvREAL(ary)) {
4075                 sv_2mortal(*MARK);
4076                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4077                     SvREFCNT_dec(*dst++);       /* free them now */
4078             }
4079         }
4080         AvFILLp(ary) += diff;
4081
4082         /* pull up or down? */
4083
4084         if (offset < after) {                   /* easier to pull up */
4085             if (offset) {                       /* esp. if nothing to pull */
4086                 src = &AvARRAY(ary)[offset-1];
4087                 dst = src - diff;               /* diff is negative */
4088                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4089                     *dst-- = *src--;
4090             }
4091             dst = AvARRAY(ary);
4092             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4093             AvMAX(ary) += diff;
4094         }
4095         else {
4096             if (after) {                        /* anything to pull down? */
4097                 src = AvARRAY(ary) + offset + length;
4098                 dst = src + diff;               /* diff is negative */
4099                 Move(src, dst, after, SV*);
4100             }
4101             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4102                                                 /* avoid later double free */
4103         }
4104         i = -diff;
4105         while (i)
4106             dst[--i] = &PL_sv_undef;
4107
4108         if (newlen) {
4109             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4110               newlen; newlen--) {
4111                 *dst = NEWSV(46, 0);
4112                 sv_setsv(*dst++, *src++);
4113             }
4114             Safefree(tmparyval);
4115         }
4116     }
4117     else {                                      /* no, expanding (or same) */
4118         if (length) {
4119             New(452, tmparyval, length, SV*);   /* so remember deletion */
4120             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4121         }
4122
4123         if (diff > 0) {                         /* expanding */
4124
4125             /* push up or down? */
4126
4127             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4128                 if (offset) {
4129                     src = AvARRAY(ary);
4130                     dst = src - diff;
4131                     Move(src, dst, offset, SV*);
4132                 }
4133                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4134                 AvMAX(ary) += diff;
4135                 AvFILLp(ary) += diff;
4136             }
4137             else {
4138                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4139                     av_extend(ary, AvFILLp(ary) + diff);
4140                 AvFILLp(ary) += diff;
4141
4142                 if (after) {
4143                     dst = AvARRAY(ary) + AvFILLp(ary);
4144                     src = dst - diff;
4145                     for (i = after; i; i--) {
4146                         *dst-- = *src--;
4147                     }
4148                 }
4149             }
4150         }
4151
4152         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4153             *dst = NEWSV(46, 0);
4154             sv_setsv(*dst++, *src++);
4155         }
4156         MARK = ORIGMARK + 1;
4157         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4158             if (length) {
4159                 Copy(tmparyval, MARK, length, SV*);
4160                 if (AvREAL(ary)) {
4161                     EXTEND_MORTAL(length);
4162                     for (i = length, dst = MARK; i; i--) {
4163                         sv_2mortal(*dst);       /* free them eventualy */
4164                         dst++;
4165                     }
4166                 }
4167                 Safefree(tmparyval);
4168             }
4169             MARK += length - 1;
4170         }
4171         else if (length--) {
4172             *MARK = tmparyval[length];
4173             if (AvREAL(ary)) {
4174                 sv_2mortal(*MARK);
4175                 while (length-- > 0)
4176                     SvREFCNT_dec(tmparyval[length]);
4177             }
4178             Safefree(tmparyval);
4179         }
4180         else
4181             *MARK = &PL_sv_undef;
4182     }
4183     SP = MARK;
4184     RETURN;
4185 }
4186
4187 PP(pp_push)
4188 {
4189     dSP; dMARK; dORIGMARK; dTARGET;
4190     register AV *ary = (AV*)*++MARK;
4191     register SV *sv = &PL_sv_undef;
4192     MAGIC *mg;
4193
4194     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4195         *MARK-- = SvTIED_obj((SV*)ary, mg);
4196         PUSHMARK(MARK);
4197         PUTBACK;
4198         ENTER;
4199         call_method("PUSH",G_SCALAR|G_DISCARD);
4200         LEAVE;
4201         SPAGAIN;
4202     }
4203     else {
4204         /* Why no pre-extend of ary here ? */
4205         for (++MARK; MARK <= SP; MARK++) {
4206             sv = NEWSV(51, 0);
4207             if (*MARK)
4208                 sv_setsv(sv, *MARK);
4209             av_push(ary, sv);
4210         }
4211     }
4212     SP = ORIGMARK;
4213     PUSHi( AvFILL(ary) + 1 );
4214     RETURN;
4215 }
4216
4217 PP(pp_pop)
4218 {
4219     dSP;
4220     AV *av = (AV*)POPs;
4221     SV *sv = av_pop(av);
4222     if (AvREAL(av))
4223         (void)sv_2mortal(sv);
4224     PUSHs(sv);
4225     RETURN;
4226 }
4227
4228 PP(pp_shift)
4229 {
4230     dSP;
4231     AV *av = (AV*)POPs;
4232     SV *sv = av_shift(av);
4233     EXTEND(SP, 1);
4234     if (!sv)
4235         RETPUSHUNDEF;
4236     if (AvREAL(av))
4237         (void)sv_2mortal(sv);
4238     PUSHs(sv);
4239     RETURN;
4240 }
4241
4242 PP(pp_unshift)
4243 {
4244     dSP; dMARK; dORIGMARK; dTARGET;
4245     register AV *ary = (AV*)*++MARK;
4246     register SV *sv;
4247     register I32 i = 0;
4248     MAGIC *mg;
4249
4250     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4251         *MARK-- = SvTIED_obj((SV*)ary, mg);
4252         PUSHMARK(MARK);
4253         PUTBACK;
4254         ENTER;
4255         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4256         LEAVE;
4257         SPAGAIN;
4258     }
4259     else {
4260         av_unshift(ary, SP - MARK);
4261         while (MARK < SP) {
4262             sv = NEWSV(27, 0);
4263             sv_setsv(sv, *++MARK);
4264             (void)av_store(ary, i++, sv);
4265         }
4266     }
4267     SP = ORIGMARK;
4268     PUSHi( AvFILL(ary) + 1 );
4269     RETURN;
4270 }
4271
4272 PP(pp_reverse)
4273 {
4274     dSP; dMARK;
4275     register SV *tmp;
4276     SV **oldsp = SP;
4277
4278     if (GIMME == G_ARRAY) {
4279         MARK++;
4280         while (MARK < SP) {
4281             tmp = *MARK;
4282             *MARK++ = *SP;
4283             *SP-- = tmp;
4284         }
4285         /* safe as long as stack cannot get extended in the above */
4286         SP = oldsp;
4287     }
4288     else {
4289         register char *up;
4290         register char *down;
4291         register I32 tmp;
4292         dTARGET;
4293         STRLEN len;
4294
4295         SvUTF8_off(TARG);                               /* decontaminate */
4296         if (SP - MARK > 1)
4297             do_join(TARG, &PL_sv_no, MARK, SP);
4298         else
4299             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4300         up = SvPV_force(TARG, len);
4301         if (len > 1) {
4302             if (DO_UTF8(TARG)) {        /* first reverse each character */
4303                 U8* s = (U8*)SvPVX(TARG);
4304                 U8* send = (U8*)(s + len);
4305                 while (s < send) {
4306                     if (UTF8_IS_INVARIANT(*s)) {
4307                         s++;
4308                         continue;
4309                     }
4310                     else {
4311                         if (!utf8_to_uvchr(s, 0))
4312                             break;
4313                         up = (char*)s;
4314                         s += UTF8SKIP(s);
4315                         down = (char*)(s - 1);
4316                         /* reverse this character */
4317                         while (down > up) {
4318                             tmp = *up;
4319                             *up++ = *down;
4320                             *down-- = (char)tmp;
4321                         }
4322                     }
4323                 }
4324                 up = SvPVX(TARG);
4325             }
4326             down = SvPVX(TARG) + len - 1;
4327             while (down > up) {
4328                 tmp = *up;
4329                 *up++ = *down;
4330                 *down-- = (char)tmp;
4331             }
4332             (void)SvPOK_only_UTF8(TARG);
4333         }
4334         SP = MARK + 1;
4335         SETTARG;
4336     }
4337     RETURN;
4338 }
4339
4340 PP(pp_split)
4341 {
4342     dSP; dTARG;
4343     AV *ary;
4344     register IV limit = POPi;                   /* note, negative is forever */
4345     SV *sv = POPs;
4346     STRLEN len;
4347     register char *s = SvPV(sv, len);
4348     bool do_utf8 = DO_UTF8(sv);
4349     char *strend = s + len;
4350     register PMOP *pm;
4351     register REGEXP *rx;
4352     register SV *dstr;
4353     register char *m;
4354     I32 iters = 0;
4355     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4356     I32 maxiters = slen + 10;
4357     I32 i;
4358     char *orig;
4359     I32 origlimit = limit;
4360     I32 realarray = 0;
4361     I32 base;
4362     AV *oldstack = PL_curstack;
4363     I32 gimme = GIMME_V;
4364     I32 oldsave = PL_savestack_ix;
4365     I32 make_mortal = 1;
4366     MAGIC *mg = (MAGIC *) NULL;
4367
4368 #ifdef DEBUGGING
4369     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4370 #else
4371     pm = (PMOP*)POPs;
4372 #endif
4373     if (!pm || !s)
4374         DIE(aTHX_ "panic: pp_split");
4375     rx = PM_GETRE(pm);
4376
4377     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4378              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4379
4380     RX_MATCH_UTF8_set(rx, do_utf8);
4381
4382     if (pm->op_pmreplroot) {
4383 #ifdef USE_ITHREADS
4384         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4385 #else
4386         ary = GvAVn((GV*)pm->op_pmreplroot);
4387 #endif
4388     }
4389     else if (gimme != G_ARRAY)
4390         ary = GvAVn(PL_defgv);
4391     else
4392         ary = Nullav;
4393     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4394         realarray = 1;
4395         PUTBACK;
4396         av_extend(ary,0);
4397         av_clear(ary);
4398         SPAGAIN;
4399         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4400             PUSHMARK(SP);
4401             XPUSHs(SvTIED_obj((SV*)ary, mg));
4402         }
4403         else {
4404             if (!AvREAL(ary)) {
4405                 AvREAL_on(ary);
4406                 AvREIFY_off(ary);
4407                 for (i = AvFILLp(ary); i >= 0; i--)
4408                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4409             }
4410             /* temporarily switch stacks */
4411             SWITCHSTACK(PL_curstack, ary);
4412             PL_curstackinfo->si_stack = ary;
4413             make_mortal = 0;
4414         }
4415     }
4416     base = SP - PL_stack_base;
4417     orig = s;
4418     if (pm->op_pmflags & PMf_SKIPWHITE) {
4419         if (pm->op_pmflags & PMf_LOCALE) {
4420             while (isSPACE_LC(*s))
4421                 s++;
4422         }
4423         else {
4424             while (isSPACE(*s))
4425                 s++;
4426         }
4427     }
4428     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
4429         SAVEINT(PL_multiline);
4430         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4431     }
4432
4433     if (!limit)
4434         limit = maxiters + 2;
4435     if (pm->op_pmflags & PMf_WHITE) {
4436         while (--limit) {
4437             m = s;
4438             while (m < strend &&
4439                    !((pm->op_pmflags & PMf_LOCALE)
4440                      ? isSPACE_LC(*m) : isSPACE(*m)))
4441                 ++m;
4442             if (m >= strend)
4443                 break;
4444
4445             dstr = NEWSV(30, m-s);
4446             sv_setpvn(dstr, s, m-s);
4447             if (make_mortal)
4448                 sv_2mortal(dstr);
4449             if (do_utf8)
4450                 (void)SvUTF8_on(dstr);
4451             XPUSHs(dstr);
4452
4453             s = m + 1;
4454             while (s < strend &&
4455                    ((pm->op_pmflags & PMf_LOCALE)
4456                     ? isSPACE_LC(*s) : isSPACE(*s)))
4457                 ++s;
4458         }
4459     }
4460     else if (strEQ("^", rx->precomp)) {
4461         while (--limit) {
4462             /*SUPPRESS 530*/
4463             for (m = s; m < strend && *m != '\n'; m++) ;
4464             m++;
4465             if (m >= strend)
4466                 break;
4467             dstr = NEWSV(30, m-s);
4468             sv_setpvn(dstr, s, m-s);
4469             if (make_mortal)
4470                 sv_2mortal(dstr);
4471             if (do_utf8)
4472                 (void)SvUTF8_on(dstr);
4473             XPUSHs(dstr);
4474             s = m;
4475         }
4476     }
4477     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4478              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4479              && (rx->reganch & ROPT_CHECK_ALL)
4480              && !(rx->reganch & ROPT_ANCH)) {
4481         int tail = (rx->reganch & RE_INTUIT_TAIL);
4482         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4483
4484         len = rx->minlen;
4485         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4486             STRLEN n_a;
4487             char c = *SvPV(csv, n_a);
4488             while (--limit) {
4489                 /*SUPPRESS 530*/
4490                 for (m = s; m < strend && *m != c; m++) ;
4491                 if (m >= strend)
4492                     break;
4493                 dstr = NEWSV(30, m-s);
4494                 sv_setpvn(dstr, s, m-s);
4495                 if (make_mortal)
4496                     sv_2mortal(dstr);
4497                 if (do_utf8)
4498                     (void)SvUTF8_on(dstr);
4499                 XPUSHs(dstr);
4500                 /* The rx->minlen is in characters but we want to step
4501                  * s ahead by bytes. */
4502                 if (do_utf8)
4503                     s = (char*)utf8_hop((U8*)m, len);
4504                 else
4505                     s = m + len; /* Fake \n at the end */
4506             }
4507         }
4508         else {
4509 #ifndef lint
4510             while (s < strend && --limit &&
4511               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4512                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4513 #endif
4514             {
4515                 dstr = NEWSV(31, m-s);
4516                 sv_setpvn(dstr, s, m-s);
4517                 if (make_mortal)
4518                     sv_2mortal(dstr);
4519                 if (do_utf8)
4520                     (void)SvUTF8_on(dstr);
4521                 XPUSHs(dstr);
4522                 /* The rx->minlen is in characters but we want to step
4523                  * s ahead by bytes. */
4524                 if (do_utf8)
4525                     s = (char*)utf8_hop((U8*)m, len);
4526                 else
4527                     s = m + len; /* Fake \n at the end */
4528             }
4529         }
4530     }
4531     else {
4532         maxiters += slen * rx->nparens;
4533         while (s < strend && --limit)
4534         {
4535             PUTBACK;
4536             i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4537             SPAGAIN;
4538             if (i == 0)
4539                 break;
4540             TAINT_IF(RX_MATCH_TAINTED(rx));
4541             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4542                 m = s;
4543                 s = orig;
4544                 orig = rx->subbeg;
4545                 s = orig + (m - s);
4546                 strend = s + (strend - m);
4547             }
4548             m = rx->startp[0] + orig;
4549             dstr = NEWSV(32, m-s);
4550             sv_setpvn(dstr, s, m-s);
4551             if (make_mortal)
4552                 sv_2mortal(dstr);
4553             if (do_utf8)
4554                 (void)SvUTF8_on(dstr);
4555             XPUSHs(dstr);
4556             if (rx->nparens) {
4557                 for (i = 1; i <= (I32)rx->nparens; i++) {
4558                     s = rx->startp[i] + orig;
4559                     m = rx->endp[i] + orig;
4560
4561                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4562                        parens that didn't match -- they should be set to
4563                        undef, not the empty string */
4564                     if (m >= orig && s >= orig) {
4565                         dstr = NEWSV(33, m-s);
4566                         sv_setpvn(dstr, s, m-s);
4567                     }
4568                     else
4569                         dstr = &PL_sv_undef;  /* undef, not "" */
4570                     if (make_mortal)
4571                         sv_2mortal(dstr);
4572                     if (do_utf8)
4573                         (void)SvUTF8_on(dstr);
4574                     XPUSHs(dstr);
4575                 }
4576             }
4577             s = rx->endp[0] + orig;
4578         }
4579     }
4580
4581     LEAVE_SCOPE(oldsave);
4582     iters = (SP - PL_stack_base) - base;
4583     if (iters > maxiters)
4584         DIE(aTHX_ "Split loop");
4585
4586     /* keep field after final delim? */
4587     if (s < strend || (iters && origlimit)) {
4588         STRLEN l = strend - s;
4589         dstr = NEWSV(34, l);
4590         sv_setpvn(dstr, s, l);
4591         if (make_mortal)
4592             sv_2mortal(dstr);
4593         if (do_utf8)
4594             (void)SvUTF8_on(dstr);
4595         XPUSHs(dstr);
4596         iters++;
4597     }
4598     else if (!origlimit) {
4599         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4600             if (TOPs && !make_mortal)
4601                 sv_2mortal(TOPs);
4602             iters--;
4603             SP--;
4604         }
4605     }
4606
4607     if (realarray) {
4608         if (!mg) {
4609             SWITCHSTACK(ary, oldstack);
4610             PL_curstackinfo->si_stack = oldstack;
4611             if (SvSMAGICAL(ary)) {
4612                 PUTBACK;
4613                 mg_set((SV*)ary);
4614                 SPAGAIN;
4615             }
4616             if (gimme == G_ARRAY) {
4617                 EXTEND(SP, iters);
4618                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4619                 SP += iters;
4620                 RETURN;
4621             }
4622         }
4623         else {
4624             PUTBACK;
4625             ENTER;
4626             call_method("PUSH",G_SCALAR|G_DISCARD);
4627             LEAVE;
4628             SPAGAIN;
4629             if (gimme == G_ARRAY) {
4630                 /* EXTEND should not be needed - we just popped them */
4631                 EXTEND(SP, iters);
4632                 for (i=0; i < iters; i++) {
4633                     SV **svp = av_fetch(ary, i, FALSE);
4634                     PUSHs((svp) ? *svp : &PL_sv_undef);
4635                 }
4636                 RETURN;
4637             }
4638         }
4639     }
4640     else {
4641         if (gimme == G_ARRAY)
4642             RETURN;
4643     }
4644
4645     GETTARGET;
4646     PUSHi(iters);
4647     RETURN;
4648 }
4649
4650 PP(pp_lock)
4651 {
4652     dSP;
4653     dTOPss;
4654     SV *retsv = sv;
4655     SvLOCK(sv);
4656     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4657         || SvTYPE(retsv) == SVt_PVCV) {
4658         retsv = refto(retsv);
4659     }
4660     SETs(retsv);
4661     RETURN;
4662 }
4663
4664 PP(pp_threadsv)
4665 {
4666     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4667 }