pp.c

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