pp.c

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