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