pp.c

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