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