pp.c

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