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 STATIC
2461 PP(pp_i_modulo_0)
2462 {
2463      /* This is the vanilla old i_modulo. */
2464      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2465      {
2466           dPOPTOPiirl;
2467           if (!right)
2468                DIE(aTHX_ "Illegal modulus zero");
2469           SETi( left % right );
2470           RETURN;
2471      }
2472 }
2473
2474 STATIC
2475 PP(pp_i_modulo_1)
2476 {
2477 #ifdef __GLIBC__
2478      /* This is the i_modulo with the workaround for the _moddi3 bug
2479       * in (at least) glibc 2.2.5 (the "right = -right" is the workaround).
2480       * See below for pp_i_modulo. */
2481      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2482      {
2483           dPOPTOPiirl;
2484           if (!right)
2485                DIE(aTHX_ "Illegal modulus zero");
2486           if (right < 0)
2487                right = -right;
2488           SETi( left % right );
2489           RETURN;
2490      }
2491 #endif
2492 }
2493
2494 PP(pp_i_modulo)
2495 {
2496      dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2497      {
2498           dPOPTOPiirl;
2499           if (!right)
2500                DIE(aTHX_ "Illegal modulus zero");
2501           /* The assumption is to use hereafter the old vanilla version... */
2502           PL_op->op_ppaddr =
2503                PL_ppaddr[OP_I_MODULO] =
2504                    &Perl_pp_i_modulo_0;
2505           /* .. but if we have glibc, we might have a buggy _moddi3
2506            * (at least glicb 2.2.5 is known to have this bug), in other
2507            * words our integer modulus with negative quad as the second
2508            * argument might be broken.  Test for this and re-patch the
2509            * opcode dispatch table if that is the case, remembering to
2510            * also apply the workaround so that this first round works
2511            * right, too.  See [perl #9402] for more information. */
2512 #if defined(__GLIBC__) && IVSIZE == 8
2513           {
2514                IV l =   3;
2515                IV r = -10;
2516                /* Cannot do this check with inlined IV constants since
2517                 * that seems to work correctly even with the buggy glibc. */
2518                if (l % r == -3) {
2519                     /* Yikes, we have the bug.
2520                      * Patch in the workaround version. */
2521                     PL_op->op_ppaddr =
2522                          PL_ppaddr[OP_I_MODULO] =
2523                              &Perl_pp_i_modulo_1;
2524                     /* Make certain we work right this time, too. */
2525                     if (right < 0)
2526                          right = -right;
2527                }
2528           }
2529 #endif
2530           SETi( left % right );
2531           RETURN;
2532      }
2533 }
2534
2535 PP(pp_i_add)
2536 {
2537     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2538     {
2539       dPOPTOPiirl_ul;
2540       SETi( left + right );
2541       RETURN;
2542     }
2543 }
2544
2545 PP(pp_i_subtract)
2546 {
2547     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2548     {
2549       dPOPTOPiirl_ul;
2550       SETi( left - right );
2551       RETURN;
2552     }
2553 }
2554
2555 PP(pp_i_lt)
2556 {
2557     dSP; tryAMAGICbinSET(lt,0);
2558     {
2559       dPOPTOPiirl;
2560       SETs(boolSV(left < right));
2561       RETURN;
2562     }
2563 }
2564
2565 PP(pp_i_gt)
2566 {
2567     dSP; tryAMAGICbinSET(gt,0);
2568     {
2569       dPOPTOPiirl;
2570       SETs(boolSV(left > right));
2571       RETURN;
2572     }
2573 }
2574
2575 PP(pp_i_le)
2576 {
2577     dSP; tryAMAGICbinSET(le,0);
2578     {
2579       dPOPTOPiirl;
2580       SETs(boolSV(left <= right));
2581       RETURN;
2582     }
2583 }
2584
2585 PP(pp_i_ge)
2586 {
2587     dSP; tryAMAGICbinSET(ge,0);
2588     {
2589       dPOPTOPiirl;
2590       SETs(boolSV(left >= right));
2591       RETURN;
2592     }
2593 }
2594
2595 PP(pp_i_eq)
2596 {
2597     dSP; tryAMAGICbinSET(eq,0);
2598     {
2599       dPOPTOPiirl;
2600       SETs(boolSV(left == right));
2601       RETURN;
2602     }
2603 }
2604
2605 PP(pp_i_ne)
2606 {
2607     dSP; tryAMAGICbinSET(ne,0);
2608     {
2609       dPOPTOPiirl;
2610       SETs(boolSV(left != right));
2611       RETURN;
2612     }
2613 }
2614
2615 PP(pp_i_ncmp)
2616 {
2617     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2618     {
2619       dPOPTOPiirl;
2620       I32 value;
2621
2622       if (left > right)
2623         value = 1;
2624       else if (left < right)
2625         value = -1;
2626       else
2627         value = 0;
2628       SETi(value);
2629       RETURN;
2630     }
2631 }
2632
2633 PP(pp_i_negate)
2634 {
2635     dSP; dTARGET; tryAMAGICun(neg);
2636     SETi(-TOPi);
2637     RETURN;
2638 }
2639
2640 /* High falutin' math. */
2641
2642 PP(pp_atan2)
2643 {
2644     dSP; dTARGET; tryAMAGICbin(atan2,0);
2645     {
2646       dPOPTOPnnrl;
2647       SETn(Perl_atan2(left, right));
2648       RETURN;
2649     }
2650 }
2651
2652 PP(pp_sin)
2653 {
2654     dSP; dTARGET; tryAMAGICun(sin);
2655     {
2656       NV value;
2657       value = POPn;
2658       value = Perl_sin(value);
2659       XPUSHn(value);
2660       RETURN;
2661     }
2662 }
2663
2664 PP(pp_cos)
2665 {
2666     dSP; dTARGET; tryAMAGICun(cos);
2667     {
2668       NV value;
2669       value = POPn;
2670       value = Perl_cos(value);
2671       XPUSHn(value);
2672       RETURN;
2673     }
2674 }
2675
2676 /* Support Configure command-line overrides for rand() functions.
2677    After 5.005, perhaps we should replace this by Configure support
2678    for drand48(), random(), or rand().  For 5.005, though, maintain
2679    compatibility by calling rand() but allow the user to override it.
2680    See INSTALL for details.  --Andy Dougherty  15 July 1998
2681 */
2682 /* Now it's after 5.005, and Configure supports drand48() and random(),
2683    in addition to rand().  So the overrides should not be needed any more.
2684    --Jarkko Hietaniemi  27 September 1998
2685  */
2686
2687 #ifndef HAS_DRAND48_PROTO
2688 extern double drand48 (void);
2689 #endif
2690
2691 PP(pp_rand)
2692 {
2693     dSP; dTARGET;
2694     NV value;
2695     if (MAXARG < 1)
2696         value = 1.0;
2697     else
2698         value = POPn;
2699     if (value == 0.0)
2700         value = 1.0;
2701     if (!PL_srand_called) {
2702         (void)seedDrand01((Rand_seed_t)seed());
2703         PL_srand_called = TRUE;
2704     }
2705     value *= Drand01();
2706     XPUSHn(value);
2707     RETURN;
2708 }
2709
2710 PP(pp_srand)
2711 {
2712     dSP;
2713     UV anum;
2714     if (MAXARG < 1)
2715         anum = seed();
2716     else
2717         anum = POPu;
2718     (void)seedDrand01((Rand_seed_t)anum);
2719     PL_srand_called = TRUE;
2720     EXTEND(SP, 1);
2721     RETPUSHYES;
2722 }
2723
2724 STATIC U32
2725 S_seed(pTHX)
2726 {
2727     /*
2728      * This is really just a quick hack which grabs various garbage
2729      * values.  It really should be a real hash algorithm which
2730      * spreads the effect of every input bit onto every output bit,
2731      * if someone who knows about such things would bother to write it.
2732      * Might be a good idea to add that function to CORE as well.
2733      * No numbers below come from careful analysis or anything here,
2734      * except they are primes and SEED_C1 > 1E6 to get a full-width
2735      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
2736      * probably be bigger too.
2737      */
2738 #if RANDBITS > 16
2739 #  define SEED_C1       1000003
2740 #define   SEED_C4       73819
2741 #else
2742 #  define SEED_C1       25747
2743 #define   SEED_C4       20639
2744 #endif
2745 #define   SEED_C2       3
2746 #define   SEED_C3       269
2747 #define   SEED_C5       26107
2748
2749 #ifndef PERL_NO_DEV_RANDOM
2750     int fd;
2751 #endif
2752     U32 u;
2753 #ifdef VMS
2754 #  include <starlet.h>
2755     /* when[] = (low 32 bits, high 32 bits) of time since epoch
2756      * in 100-ns units, typically incremented ever 10 ms.        */
2757     unsigned int when[2];
2758 #else
2759 #  ifdef HAS_GETTIMEOFDAY
2760     struct timeval when;
2761 #  else
2762     Time_t when;
2763 #  endif
2764 #endif
2765
2766 /* This test is an escape hatch, this symbol isn't set by Configure. */
2767 #ifndef PERL_NO_DEV_RANDOM
2768 #ifndef PERL_RANDOM_DEVICE
2769    /* /dev/random isn't used by default because reads from it will block
2770     * if there isn't enough entropy available.  You can compile with
2771     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2772     * is enough real entropy to fill the seed. */
2773 #  define PERL_RANDOM_DEVICE "/dev/urandom"
2774 #endif
2775     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2776     if (fd != -1) {
2777         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2778             u = 0;
2779         PerlLIO_close(fd);
2780         if (u)
2781             return u;
2782     }
2783 #endif
2784
2785 #ifdef VMS
2786     _ckvmssts(sys$gettim(when));
2787     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2788 #else
2789 #  ifdef HAS_GETTIMEOFDAY
2790     PerlProc_gettimeofday(&when,NULL);
2791     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2792 #  else
2793     (void)time(&when);
2794     u = (U32)SEED_C1 * when;
2795 #  endif
2796 #endif
2797     u += SEED_C3 * (U32)PerlProc_getpid();
2798     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2799 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
2800     u += SEED_C5 * (U32)PTR2UV(&when);
2801 #endif
2802     return u;
2803 }
2804
2805 PP(pp_exp)
2806 {
2807     dSP; dTARGET; tryAMAGICun(exp);
2808     {
2809       NV value;
2810       value = POPn;
2811       value = Perl_exp(value);
2812       XPUSHn(value);
2813       RETURN;
2814     }
2815 }
2816
2817 PP(pp_log)
2818 {
2819     dSP; dTARGET; tryAMAGICun(log);
2820     {
2821       NV value;
2822       value = POPn;
2823       if (value <= 0.0) {
2824         SET_NUMERIC_STANDARD();
2825         DIE(aTHX_ "Can't take log of %"NVgf, value);
2826       }
2827       value = Perl_log(value);
2828       XPUSHn(value);
2829       RETURN;
2830     }
2831 }
2832
2833 PP(pp_sqrt)
2834 {
2835     dSP; dTARGET; tryAMAGICun(sqrt);
2836     {
2837       NV value;
2838       value = POPn;
2839       if (value < 0.0) {
2840         SET_NUMERIC_STANDARD();
2841         DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2842       }
2843       value = Perl_sqrt(value);
2844       XPUSHn(value);
2845       RETURN;
2846     }
2847 }
2848
2849 /*
2850  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2851  * These need to be revisited when a newer toolchain becomes available.
2852  */
2853 #if defined(__sparc64__) && defined(__GNUC__)
2854 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2855 #       undef  SPARC64_MODF_WORKAROUND
2856 #       define SPARC64_MODF_WORKAROUND 1
2857 #   endif
2858 #endif
2859
2860 #if defined(SPARC64_MODF_WORKAROUND)
2861 static NV
2862 sparc64_workaround_modf(NV theVal, NV *theIntRes)
2863 {
2864     NV res, ret;
2865     ret = Perl_modf(theVal, &res);
2866     *theIntRes = res;
2867     return ret;
2868 }
2869 #endif
2870
2871 PP(pp_int)
2872 {
2873     dSP; dTARGET; tryAMAGICun(int);
2874     {
2875       NV value;
2876       IV iv = TOPi; /* attempt to convert to IV if possible. */
2877       /* XXX it's arguable that compiler casting to IV might be subtly
2878          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2879          else preferring IV has introduced a subtle behaviour change bug. OTOH
2880          relying on floating point to be accurate is a bug.  */
2881
2882       if (SvIOK(TOPs)) {
2883         if (SvIsUV(TOPs)) {
2884             UV uv = TOPu;
2885             SETu(uv);
2886         } else
2887             SETi(iv);
2888       } else {
2889           value = TOPn;
2890           if (value >= 0.0) {
2891               if (value < (NV)UV_MAX + 0.5) {
2892                   SETu(U_V(value));
2893               } else {
2894 #if defined(SPARC64_MODF_WORKAROUND)
2895                 (void)sparc64_workaround_modf(value, &value);
2896 #else
2897 #   if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2898 #       ifdef HAS_MODFL_POW32_BUG
2899 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2900                 {
2901                     NV offset = Perl_modf(value, &value);
2902                     (void)Perl_modf(offset, &offset);
2903                     value += offset;
2904                 }
2905 #       else
2906                   (void)Perl_modf(value, &value);
2907 #       endif
2908 #   else
2909                   double tmp = (double)value;
2910                   (void)Perl_modf(tmp, &tmp);
2911                   value = (NV)tmp;
2912 #   endif
2913 #endif
2914                   SETn(value);
2915               }
2916           }
2917           else {
2918               if (value > (NV)IV_MIN - 0.5) {
2919                   SETi(I_V(value));
2920               } else {
2921 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2922 #   ifdef HAS_MODFL_POW32_BUG
2923 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2924                  {
2925                      NV offset = Perl_modf(-value, &value);
2926                      (void)Perl_modf(offset, &offset);
2927                      value += offset;
2928                  }
2929 #   else
2930                   (void)Perl_modf(-value, &value);
2931 #   endif
2932                   value = -value;
2933 #else
2934                   double tmp = (double)value;
2935                   (void)Perl_modf(-tmp, &tmp);
2936                   value = -(NV)tmp;
2937 #endif
2938                   SETn(value);
2939               }
2940           }
2941       }
2942     }
2943     RETURN;
2944 }
2945
2946 PP(pp_abs)
2947 {
2948     dSP; dTARGET; tryAMAGICun(abs);
2949     {
2950       /* This will cache the NV value if string isn't actually integer  */
2951       IV iv = TOPi;
2952
2953       if (SvIOK(TOPs)) {
2954         /* IVX is precise  */
2955         if (SvIsUV(TOPs)) {
2956           SETu(TOPu);   /* force it to be numeric only */
2957         } else {
2958           if (iv >= 0) {
2959             SETi(iv);
2960           } else {
2961             if (iv != IV_MIN) {
2962               SETi(-iv);
2963             } else {
2964               /* 2s complement assumption. Also, not really needed as
2965                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2966               SETu(IV_MIN);
2967             }
2968           }
2969         }
2970       } else{
2971         NV value = TOPn;
2972         if (value < 0.0)
2973           value = -value;
2974         SETn(value);
2975       }
2976     }
2977     RETURN;
2978 }
2979
2980
2981 PP(pp_hex)
2982 {
2983     dSP; dTARGET;
2984     char *tmps;
2985     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2986     STRLEN len;
2987     NV result_nv;
2988     UV result_uv;
2989     SV* sv = POPs;
2990
2991     tmps = (SvPVx(sv, len));
2992     if (DO_UTF8(sv)) {
2993          /* If Unicode, try to downgrade
2994           * If not possible, croak. */
2995          SV* tsv = sv_2mortal(newSVsv(sv));
2996
2997          SvUTF8_on(tsv);
2998          sv_utf8_downgrade(tsv, FALSE);
2999          tmps = SvPVX(tsv);
3000     }
3001     result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3002     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3003         XPUSHn(result_nv);
3004     }
3005     else {
3006         XPUSHu(result_uv);
3007     }
3008     RETURN;
3009 }
3010
3011 PP(pp_oct)
3012 {
3013     dSP; dTARGET;
3014     char *tmps;
3015     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3016     STRLEN len;
3017     NV result_nv;
3018     UV result_uv;
3019     SV* sv = POPs;
3020
3021     tmps = (SvPVx(sv, len));
3022     if (DO_UTF8(sv)) {
3023          /* If Unicode, try to downgrade
3024           * If not possible, croak. */
3025          SV* tsv = sv_2mortal(newSVsv(sv));
3026
3027          SvUTF8_on(tsv);
3028          sv_utf8_downgrade(tsv, FALSE);
3029          tmps = SvPVX(tsv);
3030     }
3031     while (*tmps && len && isSPACE(*tmps))
3032         tmps++, len--;
3033     if (*tmps == '0')
3034         tmps++, len--;
3035     if (*tmps == 'x')
3036         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3037     else if (*tmps == 'b')
3038         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3039     else
3040         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3041
3042     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3043         XPUSHn(result_nv);
3044     }
3045     else {
3046         XPUSHu(result_uv);
3047     }
3048     RETURN;
3049 }
3050
3051 /* String stuff. */
3052
3053 PP(pp_length)
3054 {
3055     dSP; dTARGET;
3056     SV *sv = TOPs;
3057
3058     if (DO_UTF8(sv))
3059         SETi(sv_len_utf8(sv));
3060     else
3061         SETi(sv_len(sv));
3062     RETURN;
3063 }
3064
3065 PP(pp_substr)
3066 {
3067     dSP; dTARGET;
3068     SV *sv;
3069     I32 len = 0;
3070     STRLEN curlen;
3071     STRLEN utf8_curlen;
3072     I32 pos;
3073     I32 rem;
3074     I32 fail;
3075     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3076     char *tmps;
3077     I32 arybase = PL_curcop->cop_arybase;
3078     SV *repl_sv = NULL;
3079     char *repl = 0;
3080     STRLEN repl_len;
3081     int num_args = PL_op->op_private & 7;
3082     bool repl_need_utf8_upgrade = FALSE;
3083     bool repl_is_utf8 = FALSE;
3084
3085     SvTAINTED_off(TARG);                        /* decontaminate */
3086     SvUTF8_off(TARG);                           /* decontaminate */
3087     if (num_args > 2) {
3088         if (num_args > 3) {
3089             repl_sv = POPs;
3090             repl = SvPV(repl_sv, repl_len);
3091             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3092         }
3093         len = POPi;
3094     }
3095     pos = POPi;
3096     sv = POPs;
3097     PUTBACK;
3098     if (repl_sv) {
3099         if (repl_is_utf8) {
3100             if (!DO_UTF8(sv))
3101                 sv_utf8_upgrade(sv);
3102         }
3103         else if (DO_UTF8(sv))
3104             repl_need_utf8_upgrade = TRUE;
3105     }
3106     tmps = SvPV(sv, curlen);
3107     if (DO_UTF8(sv)) {
3108         utf8_curlen = sv_len_utf8(sv);
3109         if (utf8_curlen == curlen)
3110             utf8_curlen = 0;
3111         else
3112             curlen = utf8_curlen;
3113     }
3114     else
3115         utf8_curlen = 0;
3116
3117     if (pos >= arybase) {
3118         pos -= arybase;
3119         rem = curlen-pos;
3120         fail = rem;
3121         if (num_args > 2) {
3122             if (len < 0) {
3123                 rem += len;
3124                 if (rem < 0)
3125                     rem = 0;
3126             }
3127             else if (rem > len)
3128                      rem = len;
3129         }
3130     }
3131     else {
3132         pos += curlen;
3133         if (num_args < 3)
3134             rem = curlen;
3135         else if (len >= 0) {
3136             rem = pos+len;
3137             if (rem > (I32)curlen)
3138                 rem = curlen;
3139         }
3140         else {
3141             rem = curlen+len;
3142             if (rem < pos)
3143                 rem = pos;
3144         }
3145         if (pos < 0)
3146             pos = 0;
3147         fail = rem;
3148         rem -= pos;
3149     }
3150     if (fail < 0) {
3151         if (lvalue || repl)
3152             Perl_croak(aTHX_ "substr outside of string");
3153         if (ckWARN(WARN_SUBSTR))
3154             Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3155         RETPUSHUNDEF;
3156     }
3157     else {
3158         I32 upos = pos;
3159         I32 urem = rem;
3160         if (utf8_curlen)
3161             sv_pos_u2b(sv, &pos, &rem);
3162         tmps += pos;
3163         sv_setpvn(TARG, tmps, rem);
3164 #ifdef USE_LOCALE_COLLATE
3165         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3166 #endif
3167         if (utf8_curlen)
3168             SvUTF8_on(TARG);
3169         if (repl) {
3170             SV* repl_sv_copy = NULL;
3171
3172             if (repl_need_utf8_upgrade) {
3173                 repl_sv_copy = newSVsv(repl_sv);
3174                 sv_utf8_upgrade(repl_sv_copy);
3175                 repl = SvPV(repl_sv_copy, repl_len);
3176                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3177             }
3178             sv_insert(sv, pos, rem, repl, repl_len);
3179             if (repl_is_utf8)
3180                 SvUTF8_on(sv);
3181             if (repl_sv_copy)
3182                 SvREFCNT_dec(repl_sv_copy);
3183         }
3184         else if (lvalue) {              /* it's an lvalue! */
3185             if (!SvGMAGICAL(sv)) {
3186                 if (SvROK(sv)) {
3187                     STRLEN n_a;
3188                     SvPV_force(sv,n_a);
3189                     if (ckWARN(WARN_SUBSTR))
3190                         Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3191                                 "Attempt to use reference as lvalue in substr");
3192                 }
3193                 if (SvOK(sv))           /* is it defined ? */
3194                     (void)SvPOK_only_UTF8(sv);
3195                 else
3196                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3197             }
3198
3199             if (SvREFCNT(TARG) > 1)     /* don't share the TARG (#20933) */
3200                 TARG = sv_newmortal();
3201             if (SvTYPE(TARG) < SVt_PVLV) {
3202                 sv_upgrade(TARG, SVt_PVLV);
3203                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3204             }
3205
3206             LvTYPE(TARG) = 'x';
3207             if (LvTARG(TARG) != sv) {
3208                 if (LvTARG(TARG))
3209                     SvREFCNT_dec(LvTARG(TARG));
3210                 LvTARG(TARG) = SvREFCNT_inc(sv);
3211             }
3212             LvTARGOFF(TARG) = upos;
3213             LvTARGLEN(TARG) = urem;
3214         }
3215     }
3216     SPAGAIN;
3217     PUSHs(TARG);                /* avoid SvSETMAGIC here */
3218     RETURN;
3219 }
3220
3221 PP(pp_vec)
3222 {
3223     dSP; dTARGET;
3224     register IV size   = POPi;
3225     register IV offset = POPi;
3226     register SV *src = POPs;
3227     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3228
3229     SvTAINTED_off(TARG);                /* decontaminate */
3230     if (lvalue) {                       /* it's an lvalue! */
3231         if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3232             TARG = sv_newmortal();
3233         if (SvTYPE(TARG) < SVt_PVLV) {
3234             sv_upgrade(TARG, SVt_PVLV);
3235             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3236         }
3237         LvTYPE(TARG) = 'v';
3238         if (LvTARG(TARG) != src) {
3239             if (LvTARG(TARG))
3240                 SvREFCNT_dec(LvTARG(TARG));
3241             LvTARG(TARG) = SvREFCNT_inc(src);
3242         }
3243         LvTARGOFF(TARG) = offset;
3244         LvTARGLEN(TARG) = size;
3245     }
3246
3247     sv_setuv(TARG, do_vecget(src, offset, size));
3248     PUSHs(TARG);
3249     RETURN;
3250 }
3251
3252 PP(pp_index)
3253 {
3254     dSP; dTARGET;
3255     SV *big;
3256     SV *little;
3257     I32 offset;
3258     I32 retval;
3259     char *tmps;
3260     char *tmps2;
3261     STRLEN biglen;
3262     I32 arybase = PL_curcop->cop_arybase;
3263
3264     if (MAXARG < 3)
3265         offset = 0;
3266     else
3267         offset = POPi - arybase;
3268     little = POPs;
3269     big = POPs;
3270     tmps = SvPV(big, biglen);
3271     if (offset > 0 && DO_UTF8(big))
3272         sv_pos_u2b(big, &offset, 0);
3273     if (offset < 0)
3274         offset = 0;
3275     else if (offset > (I32)biglen)
3276         offset = biglen;
3277     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3278       (unsigned char*)tmps + biglen, little, 0)))
3279         retval = -1;
3280     else
3281         retval = tmps2 - tmps;
3282     if (retval > 0 && DO_UTF8(big))
3283         sv_pos_b2u(big, &retval);
3284     PUSHi(retval + arybase);
3285     RETURN;
3286 }
3287
3288 PP(pp_rindex)
3289 {
3290     dSP; dTARGET;
3291     SV *big;
3292     SV *little;
3293     STRLEN blen;
3294     STRLEN llen;
3295     I32 offset;
3296     I32 retval;
3297     char *tmps;
3298     char *tmps2;
3299     I32 arybase = PL_curcop->cop_arybase;
3300
3301     if (MAXARG >= 3)
3302         offset = POPi;
3303     little = POPs;
3304     big = POPs;
3305     tmps2 = SvPV(little, llen);
3306     tmps = SvPV(big, blen);
3307     if (MAXARG < 3)
3308         offset = blen;
3309     else {
3310         if (offset > 0 && DO_UTF8(big))
3311             sv_pos_u2b(big, &offset, 0);
3312         offset = offset - arybase + llen;
3313     }
3314     if (offset < 0)
3315         offset = 0;
3316     else if (offset > (I32)blen)
3317         offset = blen;
3318     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
3319                           tmps2, tmps2 + llen)))
3320         retval = -1;
3321     else
3322         retval = tmps2 - tmps;
3323     if (retval > 0 && DO_UTF8(big))
3324         sv_pos_b2u(big, &retval);
3325     PUSHi(retval + arybase);
3326     RETURN;
3327 }
3328
3329 PP(pp_sprintf)
3330 {
3331     dSP; dMARK; dORIGMARK; dTARGET;
3332     do_sprintf(TARG, SP-MARK, MARK+1);
3333     TAINT_IF(SvTAINTED(TARG));
3334     if (DO_UTF8(*(MARK+1)))
3335         SvUTF8_on(TARG);
3336     SP = ORIGMARK;
3337     PUSHTARG;
3338     RETURN;
3339 }
3340
3341 PP(pp_ord)
3342 {
3343     dSP; dTARGET;
3344     SV *argsv = POPs;
3345     STRLEN len;
3346     U8 *s = (U8*)SvPVx(argsv, len);
3347     SV *tmpsv;
3348
3349     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3350         tmpsv = sv_2mortal(newSVsv(argsv));
3351         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3352         argsv = tmpsv;
3353     }
3354
3355     XPUSHu(DO_UTF8(argsv) ?
3356            utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3357            (*s & 0xff));
3358
3359     RETURN;
3360 }
3361
3362 PP(pp_chr)
3363 {
3364     dSP; dTARGET;
3365     char *tmps;
3366     UV value = POPu;
3367
3368     (void)SvUPGRADE(TARG,SVt_PV);
3369
3370     if (value > 255 && !IN_BYTES) {
3371         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3372         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3373         SvCUR_set(TARG, tmps - SvPVX(TARG));
3374         *tmps = '\0';
3375         (void)SvPOK_only(TARG);
3376         SvUTF8_on(TARG);
3377         XPUSHs(TARG);
3378         RETURN;
3379     }
3380
3381     SvGROW(TARG,2);
3382     SvCUR_set(TARG, 1);
3383     tmps = SvPVX(TARG);
3384     *tmps++ = (char)value;
3385     *tmps = '\0';
3386     (void)SvPOK_only(TARG);
3387     if (PL_encoding && !IN_BYTES) {
3388         sv_recode_to_utf8(TARG, PL_encoding);
3389         tmps = SvPVX(TARG);
3390         if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3391             memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3392             SvGROW(TARG,3);
3393             SvCUR_set(TARG, 2);
3394             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3395             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3396             *tmps = '\0';
3397             SvUTF8_on(TARG);
3398         }
3399     }
3400     XPUSHs(TARG);
3401     RETURN;
3402 }
3403
3404 PP(pp_crypt)
3405 {
3406     dSP; dTARGET;
3407 #ifdef HAS_CRYPT
3408     dPOPTOPssrl;
3409     STRLEN n_a;
3410     STRLEN len;
3411     char *tmps = SvPV(left, len);
3412
3413     if (DO_UTF8(left)) {
3414          /* If Unicode, try to downgrade.
3415           * If not possible, croak.
3416           * Yes, we made this up.  */
3417          SV* tsv = sv_2mortal(newSVsv(left));
3418
3419          SvUTF8_on(tsv);
3420          sv_utf8_downgrade(tsv, FALSE);
3421          tmps = SvPVX(tsv);
3422     }
3423 #   ifdef FCRYPT
3424     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3425 #   else
3426     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3427 #   endif
3428     SETs(TARG);
3429     RETURN;
3430 #else
3431     DIE(aTHX_
3432       "The crypt() function is unimplemented due to excessive paranoia.");
3433 #endif
3434 }
3435
3436 PP(pp_ucfirst)
3437 {
3438     dSP;
3439     SV *sv = TOPs;
3440     register U8 *s;
3441     STRLEN slen;
3442
3443     SvGETMAGIC(sv);
3444     if (DO_UTF8(sv) &&
3445         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3446         UTF8_IS_START(*s)) {
3447         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3448         STRLEN ulen;
3449         STRLEN tculen;
3450
3451         utf8_to_uvchr(s, &ulen);
3452         toTITLE_utf8(s, tmpbuf, &tculen);
3453         utf8_to_uvchr(tmpbuf, 0);
3454
3455         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3456             dTARGET;
3457             /* slen is the byte length of the whole SV.
3458              * ulen is the byte length of the original Unicode character
3459              * stored as UTF-8 at s.
3460              * tculen is the byte length of the freshly titlecased
3461              * Unicode character stored as UTF-8 at tmpbuf.
3462              * We first set the result to be the titlecased character,
3463              * and then append the rest of the SV data. */
3464             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3465             if (slen > ulen)
3466                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3467             SvUTF8_on(TARG);
3468             SETs(TARG);
3469         }
3470         else {
3471             s = (U8*)SvPV_force_nomg(sv, slen);
3472             Copy(tmpbuf, s, tculen, U8);
3473         }
3474     }
3475     else {
3476         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3477             dTARGET;
3478             SvUTF8_off(TARG);                           /* decontaminate */
3479             sv_setsv_nomg(TARG, sv);
3480             sv = TARG;
3481             SETs(sv);
3482         }
3483         s = (U8*)SvPV_force_nomg(sv, slen);
3484         if (*s) {
3485             if (IN_LOCALE_RUNTIME) {
3486                 TAINT;
3487                 SvTAINTED_on(sv);
3488                 *s = toUPPER_LC(*s);
3489             }
3490             else
3491                 *s = toUPPER(*s);
3492         }
3493     }
3494     SvSETMAGIC(sv);
3495     RETURN;
3496 }
3497
3498 PP(pp_lcfirst)
3499 {
3500     dSP;
3501     SV *sv = TOPs;
3502     register U8 *s;
3503     STRLEN slen;
3504
3505     SvGETMAGIC(sv);
3506     if (DO_UTF8(sv) &&
3507         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3508         UTF8_IS_START(*s)) {
3509         STRLEN ulen;
3510         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3511         U8 *tend;
3512         UV uv;
3513
3514         toLOWER_utf8(s, tmpbuf, &ulen);
3515         uv = utf8_to_uvchr(tmpbuf, 0);
3516         tend = uvchr_to_utf8(tmpbuf, uv);
3517
3518         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3519             dTARGET;
3520             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3521             if (slen > ulen)
3522                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3523             SvUTF8_on(TARG);
3524             SETs(TARG);
3525         }
3526         else {
3527             s = (U8*)SvPV_force_nomg(sv, slen);
3528             Copy(tmpbuf, s, ulen, U8);
3529         }
3530     }
3531     else {
3532         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3533             dTARGET;
3534             SvUTF8_off(TARG);                           /* decontaminate */
3535             sv_setsv_nomg(TARG, sv);
3536             sv = TARG;
3537             SETs(sv);
3538         }
3539         s = (U8*)SvPV_force_nomg(sv, slen);
3540         if (*s) {
3541             if (IN_LOCALE_RUNTIME) {
3542                 TAINT;
3543                 SvTAINTED_on(sv);
3544                 *s = toLOWER_LC(*s);
3545             }
3546             else
3547                 *s = toLOWER(*s);
3548         }
3549     }
3550     SvSETMAGIC(sv);
3551     RETURN;
3552 }
3553
3554 PP(pp_uc)
3555 {
3556     dSP;
3557     SV *sv = TOPs;
3558     register U8 *s;
3559     STRLEN len;
3560
3561     SvGETMAGIC(sv);
3562     if (DO_UTF8(sv)) {
3563         dTARGET;
3564         STRLEN ulen;
3565         register U8 *d;
3566         U8 *send;
3567         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3568
3569         s = (U8*)SvPV_nomg(sv,len);
3570         if (!len) {
3571             SvUTF8_off(TARG);                           /* decontaminate */
3572             sv_setpvn(TARG, "", 0);
3573             SETs(TARG);
3574         }
3575         else {
3576             STRLEN nchar = utf8_length(s, s + len);
3577
3578             (void)SvUPGRADE(TARG, SVt_PV);
3579             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3580             (void)SvPOK_only(TARG);
3581             d = (U8*)SvPVX(TARG);
3582             send = s + len;
3583             while (s < send) {
3584                 toUPPER_utf8(s, tmpbuf, &ulen);
3585                 Copy(tmpbuf, d, ulen, U8);
3586                 d += ulen;
3587                 s += UTF8SKIP(s);
3588             }
3589             *d = '\0';
3590             SvUTF8_on(TARG);
3591             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3592             SETs(TARG);
3593         }
3594     }
3595     else {
3596         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3597             dTARGET;
3598             SvUTF8_off(TARG);                           /* decontaminate */
3599             sv_setsv_nomg(TARG, sv);
3600             sv = TARG;
3601             SETs(sv);
3602         }
3603         s = (U8*)SvPV_force_nomg(sv, len);
3604         if (len) {
3605             register U8 *send = s + len;
3606
3607             if (IN_LOCALE_RUNTIME) {
3608                 TAINT;
3609                 SvTAINTED_on(sv);
3610                 for (; s < send; s++)
3611                     *s = toUPPER_LC(*s);
3612             }
3613             else {
3614                 for (; s < send; s++)
3615                     *s = toUPPER(*s);
3616             }
3617         }
3618     }
3619     SvSETMAGIC(sv);
3620     RETURN;
3621 }
3622
3623 PP(pp_lc)
3624 {
3625     dSP;
3626     SV *sv = TOPs;
3627     register U8 *s;
3628     STRLEN len;
3629
3630     SvGETMAGIC(sv);
3631     if (DO_UTF8(sv)) {
3632         dTARGET;
3633         STRLEN ulen;
3634         register U8 *d;
3635         U8 *send;
3636         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3637
3638         s = (U8*)SvPV_nomg(sv,len);
3639         if (!len) {
3640             SvUTF8_off(TARG);                           /* decontaminate */
3641             sv_setpvn(TARG, "", 0);
3642             SETs(TARG);
3643         }
3644         else {
3645             STRLEN nchar = utf8_length(s, s + len);
3646
3647             (void)SvUPGRADE(TARG, SVt_PV);
3648             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3649             (void)SvPOK_only(TARG);
3650             d = (U8*)SvPVX(TARG);
3651             send = s + len;
3652             while (s < send) {
3653                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3654 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3655                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3656                      /*
3657                       * Now if the sigma is NOT followed by
3658                       * /$ignorable_sequence$cased_letter/;
3659                       * and it IS preceded by
3660                       * /$cased_letter$ignorable_sequence/;
3661                       * where $ignorable_sequence is
3662                       * [\x{2010}\x{AD}\p{Mn}]*
3663                       * and $cased_letter is
3664                       * [\p{Ll}\p{Lo}\p{Lt}]
3665                       * then it should be mapped to 0x03C2,
3666                       * (GREEK SMALL LETTER FINAL SIGMA),
3667                       * instead of staying 0x03A3.
3668                       * See lib/unicore/SpecCase.txt.
3669                       */
3670                 }
3671                 Copy(tmpbuf, d, ulen, U8);
3672                 d += ulen;
3673                 s += UTF8SKIP(s);
3674             }
3675             *d = '\0';
3676             SvUTF8_on(TARG);
3677             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3678             SETs(TARG);
3679         }
3680     }
3681     else {
3682         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3683             dTARGET;
3684             SvUTF8_off(TARG);                           /* decontaminate */
3685             sv_setsv_nomg(TARG, sv);
3686             sv = TARG;
3687             SETs(sv);
3688         }
3689
3690         s = (U8*)SvPV_force_nomg(sv, len);
3691         if (len) {
3692             register U8 *send = s + len;
3693
3694             if (IN_LOCALE_RUNTIME) {
3695                 TAINT;
3696                 SvTAINTED_on(sv);
3697                 for (; s < send; s++)
3698                     *s = toLOWER_LC(*s);
3699             }
3700             else {
3701                 for (; s < send; s++)
3702                     *s = toLOWER(*s);
3703             }
3704         }
3705     }
3706     SvSETMAGIC(sv);
3707     RETURN;
3708 }
3709
3710 PP(pp_quotemeta)
3711 {
3712     dSP; dTARGET;
3713     SV *sv = TOPs;
3714     STRLEN len;
3715     register char *s = SvPV(sv,len);
3716     register char *d;
3717
3718     SvUTF8_off(TARG);                           /* decontaminate */
3719     if (len) {
3720         (void)SvUPGRADE(TARG, SVt_PV);
3721         SvGROW(TARG, (len * 2) + 1);
3722         d = SvPVX(TARG);
3723         if (DO_UTF8(sv)) {
3724             while (len) {
3725                 if (UTF8_IS_CONTINUED(*s)) {
3726                     STRLEN ulen = UTF8SKIP(s);
3727                     if (ulen > len)
3728                         ulen = len;
3729                     len -= ulen;
3730                     while (ulen--)
3731                         *d++ = *s++;
3732                 }
3733                 else {
3734                     if (!isALNUM(*s))
3735                         *d++ = '\\';
3736                     *d++ = *s++;
3737                     len--;
3738                 }
3739             }
3740             SvUTF8_on(TARG);
3741         }
3742         else {
3743             while (len--) {
3744                 if (!isALNUM(*s))
3745                     *d++ = '\\';
3746                 *d++ = *s++;
3747             }
3748         }
3749         *d = '\0';
3750         SvCUR_set(TARG, d - SvPVX(TARG));
3751         (void)SvPOK_only_UTF8(TARG);
3752     }
3753     else
3754         sv_setpvn(TARG, s, len);
3755     SETs(TARG);
3756     if (SvSMAGICAL(TARG))
3757         mg_set(TARG);
3758     RETURN;
3759 }
3760
3761 /* Arrays. */
3762
3763 PP(pp_aslice)
3764 {
3765     dSP; dMARK; dORIGMARK;
3766     register SV** svp;
3767     register AV* av = (AV*)POPs;
3768     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3769     I32 arybase = PL_curcop->cop_arybase;
3770     I32 elem;
3771
3772     if (SvTYPE(av) == SVt_PVAV) {
3773         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3774             I32 max = -1;
3775             for (svp = MARK + 1; svp <= SP; svp++) {
3776                 elem = SvIVx(*svp);
3777                 if (elem > max)
3778                     max = elem;
3779             }
3780             if (max > AvMAX(av))
3781                 av_extend(av, max);
3782         }
3783         while (++MARK <= SP) {
3784             elem = SvIVx(*MARK);
3785
3786             if (elem > 0)
3787                 elem -= arybase;
3788             svp = av_fetch(av, elem, lval);
3789             if (lval) {
3790                 if (!svp || *svp == &PL_sv_undef)
3791                     DIE(aTHX_ PL_no_aelem, elem);
3792                 if (PL_op->op_private & OPpLVAL_INTRO)
3793                     save_aelem(av, elem, svp);
3794             }
3795             *MARK = svp ? *svp : &PL_sv_undef;
3796         }
3797     }
3798     if (GIMME != G_ARRAY) {
3799         MARK = ORIGMARK;
3800         *++MARK = *SP;
3801         SP = MARK;
3802     }
3803     RETURN;
3804 }
3805
3806 /* Associative arrays. */
3807
3808 PP(pp_each)
3809 {
3810     dSP;
3811     HV *hash = (HV*)POPs;
3812     HE *entry;
3813     I32 gimme = GIMME_V;
3814
3815     PUTBACK;
3816     /* might clobber stack_sp */
3817     entry = hv_iternext(hash);
3818     SPAGAIN;
3819
3820     EXTEND(SP, 2);
3821     if (entry) {
3822         SV* sv = hv_iterkeysv(entry);
3823         PUSHs(sv);      /* won't clobber stack_sp */
3824         if (gimme == G_ARRAY) {
3825             SV *val;
3826             PUTBACK;
3827             /* might clobber stack_sp */
3828             val = hv_iterval(hash, entry);
3829             SPAGAIN;
3830             PUSHs(val);
3831         }
3832     }
3833     else if (gimme == G_SCALAR)
3834         RETPUSHUNDEF;
3835
3836     RETURN;
3837 }
3838
3839 PP(pp_values)
3840 {
3841     return do_kv();
3842 }
3843
3844 PP(pp_keys)
3845 {
3846     return do_kv();
3847 }
3848
3849 PP(pp_delete)
3850 {
3851     dSP;
3852     I32 gimme = GIMME_V;
3853     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3854     SV *sv;
3855     HV *hv;
3856
3857     if (PL_op->op_private & OPpSLICE) {
3858         dMARK; dORIGMARK;
3859         U32 hvtype;
3860         hv = (HV*)POPs;
3861         hvtype = SvTYPE(hv);
3862         if (hvtype == SVt_PVHV) {                       /* hash element */
3863             while (++MARK <= SP) {
3864                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3865                 *MARK = sv ? sv : &PL_sv_undef;
3866             }
3867         }
3868         else if (hvtype == SVt_PVAV) {                  /* array element */
3869             if (PL_op->op_flags & OPf_SPECIAL) {
3870                 while (++MARK <= SP) {
3871                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3872                     *MARK = sv ? sv : &PL_sv_undef;
3873                 }
3874             }
3875         }
3876         else
3877             DIE(aTHX_ "Not a HASH reference");
3878         if (discard)
3879             SP = ORIGMARK;
3880         else if (gimme == G_SCALAR) {
3881             MARK = ORIGMARK;
3882             *++MARK = *SP;
3883             SP = MARK;
3884         }
3885     }
3886     else {
3887         SV *keysv = POPs;
3888         hv = (HV*)POPs;
3889         if (SvTYPE(hv) == SVt_PVHV)
3890             sv = hv_delete_ent(hv, keysv, discard, 0);
3891         else if (SvTYPE(hv) == SVt_PVAV) {
3892             if (PL_op->op_flags & OPf_SPECIAL)
3893                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3894             else
3895                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3896         }
3897         else
3898             DIE(aTHX_ "Not a HASH reference");
3899         if (!sv)
3900             sv = &PL_sv_undef;
3901         if (!discard)
3902             PUSHs(sv);
3903     }
3904     RETURN;
3905 }
3906
3907 PP(pp_exists)
3908 {
3909     dSP;
3910     SV *tmpsv;
3911     HV *hv;
3912
3913     if (PL_op->op_private & OPpEXISTS_SUB) {
3914         GV *gv;
3915         CV *cv;
3916         SV *sv = POPs;
3917         cv = sv_2cv(sv, &hv, &gv, FALSE);
3918         if (cv)
3919             RETPUSHYES;
3920         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3921             RETPUSHYES;
3922         RETPUSHNO;
3923     }
3924     tmpsv = POPs;
3925     hv = (HV*)POPs;
3926     if (SvTYPE(hv) == SVt_PVHV) {
3927         if (hv_exists_ent(hv, tmpsv, 0))
3928             RETPUSHYES;
3929     }
3930     else if (SvTYPE(hv) == SVt_PVAV) {
3931         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3932             if (av_exists((AV*)hv, SvIV(tmpsv)))
3933                 RETPUSHYES;
3934         }
3935     }
3936     else {
3937         DIE(aTHX_ "Not a HASH reference");
3938     }
3939     RETPUSHNO;
3940 }
3941
3942 PP(pp_hslice)
3943 {
3944     dSP; dMARK; dORIGMARK;
3945     register HV *hv = (HV*)POPs;
3946     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3947     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3948     bool other_magic = FALSE;
3949
3950     if (localizing) {
3951         MAGIC *mg;
3952         HV *stash;
3953
3954         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3955             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3956              /* Try to preserve the existenceness of a tied hash
3957               * element by using EXISTS and DELETE if possible.
3958               * Fallback to FETCH and STORE otherwise */
3959              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3960              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3961              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3962     }
3963
3964     while (++MARK <= SP) {
3965         SV *keysv = *MARK;
3966         SV **svp;
3967         HE *he;
3968         bool preeminent = FALSE;
3969
3970         if (localizing) {
3971             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3972                 hv_exists_ent(hv, keysv, 0);
3973         }
3974
3975         he = hv_fetch_ent(hv, keysv, lval, 0);
3976         svp = he ? &HeVAL(he) : 0;
3977
3978         if (lval) {
3979             if (!svp || *svp == &PL_sv_undef) {
3980                 STRLEN n_a;
3981                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3982             }
3983             if (localizing) {
3984                 if (preeminent)
3985                     save_helem(hv, keysv, svp);
3986                 else {
3987                     STRLEN keylen;
3988                     char *key = SvPV(keysv, keylen);
3989                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
3990                 }
3991             }
3992         }
3993         *MARK = svp ? *svp : &PL_sv_undef;
3994     }
3995     if (GIMME != G_ARRAY) {
3996         MARK = ORIGMARK;
3997         *++MARK = *SP;
3998         SP = MARK;
3999     }
4000     RETURN;
4001 }
4002
4003 /* List operators. */
4004
4005 PP(pp_list)
4006 {
4007     dSP; dMARK;
4008     if (GIMME != G_ARRAY) {
4009         if (++MARK <= SP)
4010             *MARK = *SP;                /* unwanted list, return last item */
4011         else
4012             *MARK = &PL_sv_undef;
4013         SP = MARK;
4014     }
4015     RETURN;
4016 }
4017
4018 PP(pp_lslice)
4019 {
4020     dSP;
4021     SV **lastrelem = PL_stack_sp;
4022     SV **lastlelem = PL_stack_base + POPMARK;
4023     SV **firstlelem = PL_stack_base + POPMARK + 1;
4024     register SV **firstrelem = lastlelem + 1;
4025     I32 arybase = PL_curcop->cop_arybase;
4026     I32 lval = PL_op->op_flags & OPf_MOD;
4027     I32 is_something_there = lval;
4028
4029     register I32 max = lastrelem - lastlelem;
4030     register SV **lelem;
4031     register I32 ix;
4032
4033     if (GIMME != G_ARRAY) {
4034         ix = SvIVx(*lastlelem);
4035         if (ix < 0)
4036             ix += max;
4037         else
4038             ix -= arybase;
4039         if (ix < 0 || ix >= max)
4040             *firstlelem = &PL_sv_undef;
4041         else
4042             *firstlelem = firstrelem[ix];
4043         SP = firstlelem;
4044         RETURN;
4045     }
4046
4047     if (max == 0) {
4048         SP = firstlelem - 1;
4049         RETURN;
4050     }
4051
4052     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4053         ix = SvIVx(*lelem);
4054         if (ix < 0)
4055             ix += max;
4056         else
4057             ix -= arybase;
4058         if (ix < 0 || ix >= max)
4059             *lelem = &PL_sv_undef;
4060         else {
4061             is_something_there = TRUE;
4062             if (!(*lelem = firstrelem[ix]))
4063                 *lelem = &PL_sv_undef;
4064         }
4065     }
4066     if (is_something_there)
4067         SP = lastlelem;
4068     else
4069         SP = firstlelem - 1;
4070     RETURN;
4071 }
4072
4073 PP(pp_anonlist)
4074 {
4075     dSP; dMARK; dORIGMARK;
4076     I32 items = SP - MARK;
4077     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4078     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4079     XPUSHs(av);
4080     RETURN;
4081 }
4082
4083 PP(pp_anonhash)
4084 {
4085     dSP; dMARK; dORIGMARK;
4086     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4087
4088     while (MARK < SP) {
4089         SV* key = *++MARK;
4090         SV *val = NEWSV(46, 0);
4091         if (MARK < SP)
4092             sv_setsv(val, *++MARK);
4093         else if (ckWARN(WARN_MISC))
4094             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4095         (void)hv_store_ent(hv,key,val,0);
4096     }
4097     SP = ORIGMARK;
4098     XPUSHs((SV*)hv);
4099     RETURN;
4100 }
4101
4102 PP(pp_splice)
4103 {
4104     dSP; dMARK; dORIGMARK;
4105     register AV *ary = (AV*)*++MARK;
4106     register SV **src;
4107     register SV **dst;
4108     register I32 i;
4109     register I32 offset;
4110     register I32 length;
4111     I32 newlen;
4112     I32 after;
4113     I32 diff;
4114     SV **tmparyval = 0;
4115     MAGIC *mg;
4116
4117     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4118         *MARK-- = SvTIED_obj((SV*)ary, mg);
4119         PUSHMARK(MARK);
4120         PUTBACK;
4121         ENTER;
4122         call_method("SPLICE",GIMME_V);
4123         LEAVE;
4124         SPAGAIN;
4125         RETURN;
4126     }
4127
4128     SP++;
4129
4130     if (++MARK < SP) {
4131         offset = i = SvIVx(*MARK);
4132         if (offset < 0)
4133             offset += AvFILLp(ary) + 1;
4134         else
4135             offset -= PL_curcop->cop_arybase;
4136         if (offset < 0)
4137             DIE(aTHX_ PL_no_aelem, i);
4138         if (++MARK < SP) {
4139             length = SvIVx(*MARK++);
4140             if (length < 0) {
4141                 length += AvFILLp(ary) - offset + 1;
4142                 if (length < 0)
4143                     length = 0;
4144             }
4145         }
4146         else
4147             length = AvMAX(ary) + 1;            /* close enough to infinity */
4148     }
4149     else {
4150         offset = 0;
4151         length = AvMAX(ary) + 1;
4152     }
4153     if (offset > AvFILLp(ary) + 1) {
4154         if (ckWARN(WARN_MISC))
4155             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4156         offset = AvFILLp(ary) + 1;
4157     }
4158     after = AvFILLp(ary) + 1 - (offset + length);
4159     if (after < 0) {                            /* not that much array */
4160         length += after;                        /* offset+length now in array */
4161         after = 0;
4162         if (!AvALLOC(ary))
4163             av_extend(ary, 0);
4164     }
4165
4166     /* At this point, MARK .. SP-1 is our new LIST */
4167
4168     newlen = SP - MARK;
4169     diff = newlen - length;
4170     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4171         av_reify(ary);
4172
4173     if (diff < 0) {                             /* shrinking the area */
4174         if (newlen) {
4175             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4176             Copy(MARK, tmparyval, newlen, SV*);
4177         }
4178
4179         MARK = ORIGMARK + 1;
4180         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4181             MEXTEND(MARK, length);
4182             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4183             if (AvREAL(ary)) {
4184                 EXTEND_MORTAL(length);
4185                 for (i = length, dst = MARK; i; i--) {
4186                     sv_2mortal(*dst);   /* free them eventualy */
4187                     dst++;
4188                 }
4189             }
4190             MARK += length - 1;
4191         }
4192         else {
4193             *MARK = AvARRAY(ary)[offset+length-1];
4194             if (AvREAL(ary)) {
4195                 sv_2mortal(*MARK);
4196                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4197                     SvREFCNT_dec(*dst++);       /* free them now */
4198             }
4199         }
4200         AvFILLp(ary) += diff;
4201
4202         /* pull up or down? */
4203
4204         if (offset < after) {                   /* easier to pull up */
4205             if (offset) {                       /* esp. if nothing to pull */
4206                 src = &AvARRAY(ary)[offset-1];
4207                 dst = src - diff;               /* diff is negative */
4208                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4209                     *dst-- = *src--;
4210             }
4211             dst = AvARRAY(ary);
4212             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4213             AvMAX(ary) += diff;
4214         }
4215         else {
4216             if (after) {                        /* anything to pull down? */
4217                 src = AvARRAY(ary) + offset + length;
4218                 dst = src + diff;               /* diff is negative */
4219                 Move(src, dst, after, SV*);
4220             }
4221             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4222                                                 /* avoid later double free */
4223         }
4224         i = -diff;
4225         while (i)
4226             dst[--i] = &PL_sv_undef;
4227
4228         if (newlen) {
4229             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4230               newlen; newlen--) {
4231                 *dst = NEWSV(46, 0);
4232                 sv_setsv(*dst++, *src++);
4233             }
4234             Safefree(tmparyval);
4235         }
4236     }
4237     else {                                      /* no, expanding (or same) */
4238         if (length) {
4239             New(452, tmparyval, length, SV*);   /* so remember deletion */
4240             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4241         }
4242
4243         if (diff > 0) {                         /* expanding */
4244
4245             /* push up or down? */
4246
4247             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4248                 if (offset) {
4249                     src = AvARRAY(ary);
4250                     dst = src - diff;
4251                     Move(src, dst, offset, SV*);
4252                 }
4253                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4254                 AvMAX(ary) += diff;
4255                 AvFILLp(ary) += diff;
4256             }
4257             else {
4258                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4259                     av_extend(ary, AvFILLp(ary) + diff);
4260                 AvFILLp(ary) += diff;
4261
4262                 if (after) {
4263                     dst = AvARRAY(ary) + AvFILLp(ary);
4264                     src = dst - diff;
4265                     for (i = after; i; i--) {
4266                         *dst-- = *src--;
4267                     }
4268                 }
4269             }
4270         }
4271
4272         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4273             *dst = NEWSV(46, 0);
4274             sv_setsv(*dst++, *src++);
4275         }
4276         MARK = ORIGMARK + 1;
4277         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4278             if (length) {
4279                 Copy(tmparyval, MARK, length, SV*);
4280                 if (AvREAL(ary)) {
4281                     EXTEND_MORTAL(length);
4282                     for (i = length, dst = MARK; i; i--) {
4283                         sv_2mortal(*dst);       /* free them eventualy */
4284                         dst++;
4285                     }
4286                 }
4287                 Safefree(tmparyval);
4288             }
4289             MARK += length - 1;
4290         }
4291         else if (length--) {
4292             *MARK = tmparyval[length];
4293             if (AvREAL(ary)) {
4294                 sv_2mortal(*MARK);
4295                 while (length-- > 0)
4296                     SvREFCNT_dec(tmparyval[length]);
4297             }
4298             Safefree(tmparyval);
4299         }
4300         else
4301             *MARK = &PL_sv_undef;
4302     }
4303     SP = MARK;
4304     RETURN;
4305 }
4306
4307 PP(pp_push)
4308 {
4309     dSP; dMARK; dORIGMARK; dTARGET;
4310     register AV *ary = (AV*)*++MARK;
4311     register SV *sv = &PL_sv_undef;
4312     MAGIC *mg;
4313
4314     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4315         *MARK-- = SvTIED_obj((SV*)ary, mg);
4316         PUSHMARK(MARK);
4317         PUTBACK;
4318         ENTER;
4319         call_method("PUSH",G_SCALAR|G_DISCARD);
4320         LEAVE;
4321         SPAGAIN;
4322     }
4323     else {
4324         /* Why no pre-extend of ary here ? */
4325         for (++MARK; MARK <= SP; MARK++) {
4326             sv = NEWSV(51, 0);
4327             if (*MARK)
4328                 sv_setsv(sv, *MARK);
4329             av_push(ary, sv);
4330         }
4331     }
4332     SP = ORIGMARK;
4333     PUSHi( AvFILL(ary) + 1 );
4334     RETURN;
4335 }
4336
4337 PP(pp_pop)
4338 {
4339     dSP;
4340     AV *av = (AV*)POPs;
4341     SV *sv = av_pop(av);
4342     if (AvREAL(av))
4343         (void)sv_2mortal(sv);
4344     PUSHs(sv);
4345     RETURN;
4346 }
4347
4348 PP(pp_shift)
4349 {
4350     dSP;
4351     AV *av = (AV*)POPs;
4352     SV *sv = av_shift(av);
4353     EXTEND(SP, 1);
4354     if (!sv)
4355         RETPUSHUNDEF;
4356     if (AvREAL(av))
4357         (void)sv_2mortal(sv);
4358     PUSHs(sv);
4359     RETURN;
4360 }
4361
4362 PP(pp_unshift)
4363 {
4364     dSP; dMARK; dORIGMARK; dTARGET;
4365     register AV *ary = (AV*)*++MARK;
4366     register SV *sv;
4367     register I32 i = 0;
4368     MAGIC *mg;
4369
4370     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4371         *MARK-- = SvTIED_obj((SV*)ary, mg);
4372         PUSHMARK(MARK);
4373         PUTBACK;
4374         ENTER;
4375         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4376         LEAVE;
4377         SPAGAIN;
4378     }
4379     else {
4380         av_unshift(ary, SP - MARK);
4381         while (MARK < SP) {
4382             sv = NEWSV(27, 0);
4383             sv_setsv(sv, *++MARK);
4384             (void)av_store(ary, i++, sv);
4385         }
4386     }
4387     SP = ORIGMARK;
4388     PUSHi( AvFILL(ary) + 1 );
4389     RETURN;
4390 }
4391
4392 PP(pp_reverse)
4393 {
4394     dSP; dMARK;
4395     register SV *tmp;
4396     SV **oldsp = SP;
4397
4398     if (GIMME == G_ARRAY) {
4399         MARK++;
4400         while (MARK < SP) {
4401             tmp = *MARK;
4402             *MARK++ = *SP;
4403             *SP-- = tmp;
4404         }
4405         /* safe as long as stack cannot get extended in the above */
4406         SP = oldsp;
4407     }
4408     else {
4409         register char *up;
4410         register char *down;
4411         register I32 tmp;
4412         dTARGET;
4413         STRLEN len;
4414
4415         SvUTF8_off(TARG);                               /* decontaminate */
4416         if (SP - MARK > 1)
4417             do_join(TARG, &PL_sv_no, MARK, SP);
4418         else
4419             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4420         up = SvPV_force(TARG, len);
4421         if (len > 1) {
4422             if (DO_UTF8(TARG)) {        /* first reverse each character */
4423                 U8* s = (U8*)SvPVX(TARG);
4424                 U8* send = (U8*)(s + len);
4425                 while (s < send) {
4426                     if (UTF8_IS_INVARIANT(*s)) {
4427                         s++;
4428                         continue;
4429                     }
4430                     else {
4431                         if (!utf8_to_uvchr(s, 0))
4432                             break;
4433                         up = (char*)s;
4434                         s += UTF8SKIP(s);
4435                         down = (char*)(s - 1);
4436                         /* reverse this character */
4437                         while (down > up) {
4438                             tmp = *up;
4439                             *up++ = *down;
4440                             *down-- = (char)tmp;
4441                         }
4442                     }
4443                 }
4444                 up = SvPVX(TARG);
4445             }
4446             down = SvPVX(TARG) + len - 1;
4447             while (down > up) {
4448                 tmp = *up;
4449                 *up++ = *down;
4450                 *down-- = (char)tmp;
4451             }
4452             (void)SvPOK_only_UTF8(TARG);
4453         }
4454         SP = MARK + 1;
4455         SETTARG;
4456     }
4457     RETURN;
4458 }
4459
4460 PP(pp_split)
4461 {
4462     dSP; dTARG;
4463     AV *ary;
4464     register IV limit = POPi;                   /* note, negative is forever */
4465     SV *sv = POPs;
4466     STRLEN len;
4467     register char *s = SvPV(sv, len);
4468     bool do_utf8 = DO_UTF8(sv);
4469     char *strend = s + len;
4470     register PMOP *pm;
4471     register REGEXP *rx;
4472     register SV *dstr;
4473     register char *m;
4474     I32 iters = 0;
4475     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4476     I32 maxiters = slen + 10;
4477     I32 i;
4478     char *orig;
4479     I32 origlimit = limit;
4480     I32 realarray = 0;
4481     I32 base;
4482     AV *oldstack = PL_curstack;
4483     I32 gimme = GIMME_V;
4484     I32 oldsave = PL_savestack_ix;
4485     I32 make_mortal = 1;
4486     MAGIC *mg = (MAGIC *) NULL;
4487
4488 #ifdef DEBUGGING
4489     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4490 #else
4491     pm = (PMOP*)POPs;
4492 #endif
4493     if (!pm || !s)
4494         DIE(aTHX_ "panic: pp_split");
4495     rx = PM_GETRE(pm);
4496
4497     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4498              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4499
4500     RX_MATCH_UTF8_set(rx, do_utf8);
4501
4502     if (pm->op_pmreplroot) {
4503 #ifdef USE_ITHREADS
4504         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4505 #else
4506         ary = GvAVn((GV*)pm->op_pmreplroot);
4507 #endif
4508     }
4509     else if (gimme != G_ARRAY)
4510         ary = GvAVn(PL_defgv);
4511     else
4512         ary = Nullav;
4513     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4514         realarray = 1;
4515         PUTBACK;
4516         av_extend(ary,0);
4517         av_clear(ary);
4518         SPAGAIN;
4519         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4520             PUSHMARK(SP);
4521             XPUSHs(SvTIED_obj((SV*)ary, mg));
4522         }
4523         else {
4524             if (!AvREAL(ary)) {
4525                 AvREAL_on(ary);
4526                 AvREIFY_off(ary);
4527                 for (i = AvFILLp(ary); i >= 0; i--)
4528                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4529             }
4530             /* temporarily switch stacks */
4531             SWITCHSTACK(PL_curstack, ary);
4532             PL_curstackinfo->si_stack = ary;
4533             make_mortal = 0;
4534         }
4535     }
4536     base = SP - PL_stack_base;
4537     orig = s;
4538     if (pm->op_pmflags & PMf_SKIPWHITE) {
4539         if (pm->op_pmflags & PMf_LOCALE) {
4540             while (isSPACE_LC(*s))
4541                 s++;
4542         }
4543         else {
4544             while (isSPACE(*s))
4545                 s++;
4546         }
4547     }
4548     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4549         SAVEINT(PL_multiline);
4550         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4551     }
4552
4553     if (!limit)
4554         limit = maxiters + 2;
4555     if (pm->op_pmflags & PMf_WHITE) {
4556         while (--limit) {
4557             m = s;
4558             while (m < strend &&
4559                    !((pm->op_pmflags & PMf_LOCALE)
4560                      ? isSPACE_LC(*m) : isSPACE(*m)))
4561                 ++m;
4562             if (m >= strend)
4563                 break;
4564
4565             dstr = NEWSV(30, m-s);
4566             sv_setpvn(dstr, s, m-s);
4567             if (make_mortal)
4568                 sv_2mortal(dstr);
4569             if (do_utf8)
4570                 (void)SvUTF8_on(dstr);
4571             XPUSHs(dstr);
4572
4573             s = m + 1;
4574             while (s < strend &&
4575                    ((pm->op_pmflags & PMf_LOCALE)
4576                     ? isSPACE_LC(*s) : isSPACE(*s)))
4577                 ++s;
4578         }
4579     }
4580     else if (strEQ("^", rx->precomp)) {
4581         while (--limit) {
4582             /*SUPPRESS 530*/
4583             for (m = s; m < strend && *m != '\n'; m++) ;
4584             m++;
4585             if (m >= strend)
4586                 break;
4587             dstr = NEWSV(30, m-s);
4588             sv_setpvn(dstr, s, m-s);
4589             if (make_mortal)
4590                 sv_2mortal(dstr);
4591             if (do_utf8)
4592                 (void)SvUTF8_on(dstr);
4593             XPUSHs(dstr);
4594             s = m;
4595         }
4596     }
4597     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4598              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4599              && (rx->reganch & ROPT_CHECK_ALL)
4600              && !(rx->reganch & ROPT_ANCH)) {
4601         int tail = (rx->reganch & RE_INTUIT_TAIL);
4602         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4603
4604         len = rx->minlen;
4605         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4606             STRLEN n_a;
4607             char c = *SvPV(csv, n_a);
4608             while (--limit) {
4609                 /*SUPPRESS 530*/
4610                 for (m = s; m < strend && *m != c; m++) ;
4611                 if (m >= strend)
4612                     break;
4613                 dstr = NEWSV(30, m-s);
4614                 sv_setpvn(dstr, s, m-s);
4615                 if (make_mortal)
4616                     sv_2mortal(dstr);
4617                 if (do_utf8)
4618                     (void)SvUTF8_on(dstr);
4619                 XPUSHs(dstr);
4620                 /* The rx->minlen is in characters but we want to step
4621                  * s ahead by bytes. */
4622                 if (do_utf8)
4623                     s = (char*)utf8_hop((U8*)m, len);
4624                 else
4625                     s = m + len; /* Fake \n at the end */
4626             }
4627         }
4628         else {
4629 #ifndef lint
4630             while (s < strend && --limit &&
4631               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4632                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4633 #endif
4634             {
4635                 dstr = NEWSV(31, m-s);
4636                 sv_setpvn(dstr, s, m-s);
4637                 if (make_mortal)
4638                     sv_2mortal(dstr);
4639                 if (do_utf8)
4640                     (void)SvUTF8_on(dstr);
4641                 XPUSHs(dstr);
4642                 /* The rx->minlen is in characters but we want to step
4643                  * s ahead by bytes. */
4644                 if (do_utf8)
4645                     s = (char*)utf8_hop((U8*)m, len);
4646                 else
4647                     s = m + len; /* Fake \n at the end */
4648             }
4649         }
4650     }
4651     else {
4652         maxiters += slen * rx->nparens;
4653         while (s < strend && --limit
4654 /*             && (!rx->check_substr
4655                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4656                                                  0, NULL))))
4657 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4658                               1 /* minend */, sv, NULL, 0))
4659         {
4660             TAINT_IF(RX_MATCH_TAINTED(rx));
4661             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4662                 m = s;
4663                 s = orig;
4664                 orig = rx->subbeg;
4665                 s = orig + (m - s);
4666                 strend = s + (strend - m);
4667             }
4668             m = rx->startp[0] + orig;
4669             dstr = NEWSV(32, m-s);
4670             sv_setpvn(dstr, s, m-s);
4671             if (make_mortal)
4672                 sv_2mortal(dstr);
4673             if (do_utf8)
4674                 (void)SvUTF8_on(dstr);
4675             XPUSHs(dstr);
4676             if (rx->nparens) {
4677                 for (i = 1; i <= (I32)rx->nparens; i++) {
4678                     s = rx->startp[i] + orig;
4679                     m = rx->endp[i] + orig;
4680
4681                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4682                        parens that didn't match -- they should be set to
4683                        undef, not the empty string */
4684                     if (m >= orig && s >= orig) {
4685                         dstr = NEWSV(33, m-s);
4686                         sv_setpvn(dstr, s, m-s);
4687                     }
4688                     else
4689                         dstr = &PL_sv_undef;  /* undef, not "" */
4690                     if (make_mortal)
4691                         sv_2mortal(dstr);
4692                     if (do_utf8)
4693                         (void)SvUTF8_on(dstr);
4694                     XPUSHs(dstr);
4695                 }
4696             }
4697             s = rx->endp[0] + orig;
4698         }
4699     }
4700
4701     LEAVE_SCOPE(oldsave);
4702     iters = (SP - PL_stack_base) - base;
4703     if (iters > maxiters)
4704         DIE(aTHX_ "Split loop");
4705
4706     /* keep field after final delim? */
4707     if (s < strend || (iters && origlimit)) {
4708         STRLEN l = strend - s;
4709         dstr = NEWSV(34, l);
4710         sv_setpvn(dstr, s, l);
4711         if (make_mortal)
4712             sv_2mortal(dstr);
4713         if (do_utf8)
4714             (void)SvUTF8_on(dstr);
4715         XPUSHs(dstr);
4716         iters++;
4717     }
4718     else if (!origlimit) {
4719         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4720             if (TOPs && !make_mortal)
4721                 sv_2mortal(TOPs);
4722             iters--;
4723             SP--;
4724         }
4725     }
4726
4727     if (realarray) {
4728         if (!mg) {
4729             SWITCHSTACK(ary, oldstack);
4730             PL_curstackinfo->si_stack = oldstack;
4731             if (SvSMAGICAL(ary)) {
4732                 PUTBACK;
4733                 mg_set((SV*)ary);
4734                 SPAGAIN;
4735             }
4736             if (gimme == G_ARRAY) {
4737                 EXTEND(SP, iters);
4738                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4739                 SP += iters;
4740                 RETURN;
4741             }
4742         }
4743         else {
4744             PUTBACK;
4745             ENTER;
4746             call_method("PUSH",G_SCALAR|G_DISCARD);
4747             LEAVE;
4748             SPAGAIN;
4749             if (gimme == G_ARRAY) {
4750                 /* EXTEND should not be needed - we just popped them */
4751                 EXTEND(SP, iters);
4752                 for (i=0; i < iters; i++) {
4753                     SV **svp = av_fetch(ary, i, FALSE);
4754                     PUSHs((svp) ? *svp : &PL_sv_undef);
4755                 }
4756                 RETURN;
4757             }
4758         }
4759     }
4760     else {
4761         if (gimme == G_ARRAY)
4762             RETURN;
4763     }
4764     if (iters || !pm->op_pmreplroot) {
4765         GETTARGET;
4766         PUSHi(iters);
4767         RETURN;
4768     }
4769     RETPUSHUNDEF;
4770 }
4771
4772 PP(pp_lock)
4773 {
4774     dSP;
4775     dTOPss;
4776     SV *retsv = sv;
4777     SvLOCK(sv);
4778     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4779         || SvTYPE(retsv) == SVt_PVCV) {
4780         retsv = refto(retsv);
4781     }
4782     SETs(retsv);
4783     RETURN;
4784 }
4785
4786 PP(pp_threadsv)
4787 {
4788     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4789 }