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