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