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