pp.c

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