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