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             tmps = SvPVX(TARG);
3392             SvCUR_set(TARG, 2);
3393             *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3394             *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3395             *tmps = '\0';
3396             SvUTF8_on(TARG);
3397         }
3398     }
3399     XPUSHs(TARG);
3400     RETURN;
3401 }
3402
3403 PP(pp_crypt)
3404 {
3405     dSP; dTARGET;
3406 #ifdef HAS_CRYPT
3407     dPOPTOPssrl;
3408     STRLEN n_a;
3409     STRLEN len;
3410     char *tmps = SvPV(left, len);
3411
3412     if (DO_UTF8(left)) {
3413          /* If Unicode, try to downgrade.
3414           * If not possible, croak.
3415           * Yes, we made this up.  */
3416          SV* tsv = sv_2mortal(newSVsv(left));
3417
3418          SvUTF8_on(tsv);
3419          sv_utf8_downgrade(tsv, FALSE);
3420          tmps = SvPVX(tsv);
3421     }
3422 #   ifdef USE_ITHREADS
3423 #     ifdef HAS_CRYPT_R
3424     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3425       /* This should be threadsafe because in ithreads there is only
3426        * one thread per interpreter.  If this would not be true,
3427        * we would need a mutex to protect this malloc. */
3428         PL_reentrant_buffer->_crypt_struct_buffer =
3429           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3430 #if defined(__GLIBC__) || defined(__EMX__)
3431         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3432             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3433             /* work around glibc-2.2.5 bug */
3434             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3435         }
3436 #endif
3437     }
3438 #     endif /* HAS_CRYPT_R */
3439 #   endif /* USE_ITHREADS */
3440 #   ifdef FCRYPT
3441     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3442 #   else
3443     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3444 #   endif
3445     SETs(TARG);
3446     RETURN;
3447 #else
3448     DIE(aTHX_
3449       "The crypt() function is unimplemented due to excessive paranoia.");
3450 #endif
3451 }
3452
3453 PP(pp_ucfirst)
3454 {
3455     dSP;
3456     SV *sv = TOPs;
3457     register U8 *s;
3458     STRLEN slen;
3459
3460     SvGETMAGIC(sv);
3461     if (DO_UTF8(sv) &&
3462         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3463         UTF8_IS_START(*s)) {
3464         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3465         STRLEN ulen;
3466         STRLEN tculen;
3467
3468         utf8_to_uvchr(s, &ulen);
3469         toTITLE_utf8(s, tmpbuf, &tculen);
3470         utf8_to_uvchr(tmpbuf, 0);
3471
3472         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3473             dTARGET;
3474             /* slen is the byte length of the whole SV.
3475              * ulen is the byte length of the original Unicode character
3476              * stored as UTF-8 at s.
3477              * tculen is the byte length of the freshly titlecased
3478              * Unicode character stored as UTF-8 at tmpbuf.
3479              * We first set the result to be the titlecased character,
3480              * and then append the rest of the SV data. */
3481             sv_setpvn(TARG, (char*)tmpbuf, tculen);
3482             if (slen > ulen)
3483                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3484             SvUTF8_on(TARG);
3485             SETs(TARG);
3486         }
3487         else {
3488             s = (U8*)SvPV_force_nomg(sv, slen);
3489             Copy(tmpbuf, s, tculen, U8);
3490         }
3491     }
3492     else {
3493         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3494             dTARGET;
3495             SvUTF8_off(TARG);                           /* decontaminate */
3496             sv_setsv_nomg(TARG, sv);
3497             sv = TARG;
3498             SETs(sv);
3499         }
3500         s = (U8*)SvPV_force_nomg(sv, slen);
3501         if (*s) {
3502             if (IN_LOCALE_RUNTIME) {
3503                 TAINT;
3504                 SvTAINTED_on(sv);
3505                 *s = toUPPER_LC(*s);
3506             }
3507             else
3508                 *s = toUPPER(*s);
3509         }
3510     }
3511     SvSETMAGIC(sv);
3512     RETURN;
3513 }
3514
3515 PP(pp_lcfirst)
3516 {
3517     dSP;
3518     SV *sv = TOPs;
3519     register U8 *s;
3520     STRLEN slen;
3521
3522     SvGETMAGIC(sv);
3523     if (DO_UTF8(sv) &&
3524         (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3525         UTF8_IS_START(*s)) {
3526         STRLEN ulen;
3527         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3528         U8 *tend;
3529         UV uv;
3530
3531         toLOWER_utf8(s, tmpbuf, &ulen);
3532         uv = utf8_to_uvchr(tmpbuf, 0);
3533         tend = uvchr_to_utf8(tmpbuf, uv);
3534
3535         if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3536             dTARGET;
3537             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3538             if (slen > ulen)
3539                 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3540             SvUTF8_on(TARG);
3541             SETs(TARG);
3542         }
3543         else {
3544             s = (U8*)SvPV_force_nomg(sv, slen);
3545             Copy(tmpbuf, s, ulen, U8);
3546         }
3547     }
3548     else {
3549         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3550             dTARGET;
3551             SvUTF8_off(TARG);                           /* decontaminate */
3552             sv_setsv_nomg(TARG, sv);
3553             sv = TARG;
3554             SETs(sv);
3555         }
3556         s = (U8*)SvPV_force_nomg(sv, slen);
3557         if (*s) {
3558             if (IN_LOCALE_RUNTIME) {
3559                 TAINT;
3560                 SvTAINTED_on(sv);
3561                 *s = toLOWER_LC(*s);
3562             }
3563             else
3564                 *s = toLOWER(*s);
3565         }
3566     }
3567     SvSETMAGIC(sv);
3568     RETURN;
3569 }
3570
3571 PP(pp_uc)
3572 {
3573     dSP;
3574     SV *sv = TOPs;
3575     register U8 *s;
3576     STRLEN len;
3577
3578     SvGETMAGIC(sv);
3579     if (DO_UTF8(sv)) {
3580         dTARGET;
3581         STRLEN ulen;
3582         register U8 *d;
3583         U8 *send;
3584         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3585
3586         s = (U8*)SvPV_nomg(sv,len);
3587         if (!len) {
3588             SvUTF8_off(TARG);                           /* decontaminate */
3589             sv_setpvn(TARG, "", 0);
3590             SETs(TARG);
3591         }
3592         else {
3593             STRLEN nchar = utf8_length(s, s + len);
3594
3595             (void)SvUPGRADE(TARG, SVt_PV);
3596             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3597             (void)SvPOK_only(TARG);
3598             d = (U8*)SvPVX(TARG);
3599             send = s + len;
3600             while (s < send) {
3601                 toUPPER_utf8(s, tmpbuf, &ulen);
3602                 Copy(tmpbuf, d, ulen, U8);
3603                 d += ulen;
3604                 s += UTF8SKIP(s);
3605             }
3606             *d = '\0';
3607             SvUTF8_on(TARG);
3608             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3609             SETs(TARG);
3610         }
3611     }
3612     else {
3613         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3614             dTARGET;
3615             SvUTF8_off(TARG);                           /* decontaminate */
3616             sv_setsv_nomg(TARG, sv);
3617             sv = TARG;
3618             SETs(sv);
3619         }
3620         s = (U8*)SvPV_force_nomg(sv, len);
3621         if (len) {
3622             register U8 *send = s + len;
3623
3624             if (IN_LOCALE_RUNTIME) {
3625                 TAINT;
3626                 SvTAINTED_on(sv);
3627                 for (; s < send; s++)
3628                     *s = toUPPER_LC(*s);
3629             }
3630             else {
3631                 for (; s < send; s++)
3632                     *s = toUPPER(*s);
3633             }
3634         }
3635     }
3636     SvSETMAGIC(sv);
3637     RETURN;
3638 }
3639
3640 PP(pp_lc)
3641 {
3642     dSP;
3643     SV *sv = TOPs;
3644     register U8 *s;
3645     STRLEN len;
3646
3647     SvGETMAGIC(sv);
3648     if (DO_UTF8(sv)) {
3649         dTARGET;
3650         STRLEN ulen;
3651         register U8 *d;
3652         U8 *send;
3653         U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3654
3655         s = (U8*)SvPV_nomg(sv,len);
3656         if (!len) {
3657             SvUTF8_off(TARG);                           /* decontaminate */
3658             sv_setpvn(TARG, "", 0);
3659             SETs(TARG);
3660         }
3661         else {
3662             STRLEN nchar = utf8_length(s, s + len);
3663
3664             (void)SvUPGRADE(TARG, SVt_PV);
3665             SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3666             (void)SvPOK_only(TARG);
3667             d = (U8*)SvPVX(TARG);
3668             send = s + len;
3669             while (s < send) {
3670                 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3671 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3672                 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3673                      /*
3674                       * Now if the sigma is NOT followed by
3675                       * /$ignorable_sequence$cased_letter/;
3676                       * and it IS preceded by
3677                       * /$cased_letter$ignorable_sequence/;
3678                       * where $ignorable_sequence is
3679                       * [\x{2010}\x{AD}\p{Mn}]*
3680                       * and $cased_letter is
3681                       * [\p{Ll}\p{Lo}\p{Lt}]
3682                       * then it should be mapped to 0x03C2,
3683                       * (GREEK SMALL LETTER FINAL SIGMA),
3684                       * instead of staying 0x03A3.
3685                       * See lib/unicore/SpecCase.txt.
3686                       */
3687                 }
3688                 Copy(tmpbuf, d, ulen, U8);
3689                 d += ulen;
3690                 s += UTF8SKIP(s);
3691             }
3692             *d = '\0';
3693             SvUTF8_on(TARG);
3694             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3695             SETs(TARG);
3696         }
3697     }
3698     else {
3699         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3700             dTARGET;
3701             SvUTF8_off(TARG);                           /* decontaminate */
3702             sv_setsv_nomg(TARG, sv);
3703             sv = TARG;
3704             SETs(sv);
3705         }
3706
3707         s = (U8*)SvPV_force_nomg(sv, len);
3708         if (len) {
3709             register U8 *send = s + len;
3710
3711             if (IN_LOCALE_RUNTIME) {
3712                 TAINT;
3713                 SvTAINTED_on(sv);
3714                 for (; s < send; s++)
3715                     *s = toLOWER_LC(*s);
3716             }
3717             else {
3718                 for (; s < send; s++)
3719                     *s = toLOWER(*s);
3720             }
3721         }
3722     }
3723     SvSETMAGIC(sv);
3724     RETURN;
3725 }
3726
3727 PP(pp_quotemeta)
3728 {
3729     dSP; dTARGET;
3730     SV *sv = TOPs;
3731     STRLEN len;
3732     register char *s = SvPV(sv,len);
3733     register char *d;
3734
3735     SvUTF8_off(TARG);                           /* decontaminate */
3736     if (len) {
3737         (void)SvUPGRADE(TARG, SVt_PV);
3738         SvGROW(TARG, (len * 2) + 1);
3739         d = SvPVX(TARG);
3740         if (DO_UTF8(sv)) {
3741             while (len) {
3742                 if (UTF8_IS_CONTINUED(*s)) {
3743                     STRLEN ulen = UTF8SKIP(s);
3744                     if (ulen > len)
3745                         ulen = len;
3746                     len -= ulen;
3747                     while (ulen--)
3748                         *d++ = *s++;
3749                 }
3750                 else {
3751                     if (!isALNUM(*s))
3752                         *d++ = '\\';
3753                     *d++ = *s++;
3754                     len--;
3755                 }
3756             }
3757             SvUTF8_on(TARG);
3758         }
3759         else {
3760             while (len--) {
3761                 if (!isALNUM(*s))
3762                     *d++ = '\\';
3763                 *d++ = *s++;
3764             }
3765         }
3766         *d = '\0';
3767         SvCUR_set(TARG, d - SvPVX(TARG));
3768         (void)SvPOK_only_UTF8(TARG);
3769     }
3770     else
3771         sv_setpvn(TARG, s, len);
3772     SETs(TARG);
3773     if (SvSMAGICAL(TARG))
3774         mg_set(TARG);
3775     RETURN;
3776 }
3777
3778 /* Arrays. */
3779
3780 PP(pp_aslice)
3781 {
3782     dSP; dMARK; dORIGMARK;
3783     register SV** svp;
3784     register AV* av = (AV*)POPs;
3785     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3786     I32 arybase = PL_curcop->cop_arybase;
3787     I32 elem;
3788
3789     if (SvTYPE(av) == SVt_PVAV) {
3790         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3791             I32 max = -1;
3792             for (svp = MARK + 1; svp <= SP; svp++) {
3793                 elem = SvIVx(*svp);
3794                 if (elem > max)
3795                     max = elem;
3796             }
3797             if (max > AvMAX(av))
3798                 av_extend(av, max);
3799         }
3800         while (++MARK <= SP) {
3801             elem = SvIVx(*MARK);
3802
3803             if (elem > 0)
3804                 elem -= arybase;
3805             svp = av_fetch(av, elem, lval);
3806             if (lval) {
3807                 if (!svp || *svp == &PL_sv_undef)
3808                     DIE(aTHX_ PL_no_aelem, elem);
3809                 if (PL_op->op_private & OPpLVAL_INTRO)
3810                     save_aelem(av, elem, svp);
3811             }
3812             *MARK = svp ? *svp : &PL_sv_undef;
3813         }
3814     }
3815     if (GIMME != G_ARRAY) {
3816         MARK = ORIGMARK;
3817         *++MARK = *SP;
3818         SP = MARK;
3819     }
3820     RETURN;
3821 }
3822
3823 /* Associative arrays. */
3824
3825 PP(pp_each)
3826 {
3827     dSP;
3828     HV *hash = (HV*)POPs;
3829     HE *entry;
3830     I32 gimme = GIMME_V;
3831
3832     PUTBACK;
3833     /* might clobber stack_sp */
3834     entry = hv_iternext(hash);
3835     SPAGAIN;
3836
3837     EXTEND(SP, 2);
3838     if (entry) {
3839         SV* sv = hv_iterkeysv(entry);
3840         PUSHs(sv);      /* won't clobber stack_sp */
3841         if (gimme == G_ARRAY) {
3842             SV *val;
3843             PUTBACK;
3844             /* might clobber stack_sp */
3845             val = hv_iterval(hash, entry);
3846             SPAGAIN;
3847             PUSHs(val);
3848         }
3849     }
3850     else if (gimme == G_SCALAR)
3851         RETPUSHUNDEF;
3852
3853     RETURN;
3854 }
3855
3856 PP(pp_values)
3857 {
3858     return do_kv();
3859 }
3860
3861 PP(pp_keys)
3862 {
3863     return do_kv();
3864 }
3865
3866 PP(pp_delete)
3867 {
3868     dSP;
3869     I32 gimme = GIMME_V;
3870     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3871     SV *sv;
3872     HV *hv;
3873
3874     if (PL_op->op_private & OPpSLICE) {
3875         dMARK; dORIGMARK;
3876         U32 hvtype;
3877         hv = (HV*)POPs;
3878         hvtype = SvTYPE(hv);
3879         if (hvtype == SVt_PVHV) {                       /* hash element */
3880             while (++MARK <= SP) {
3881                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3882                 *MARK = sv ? sv : &PL_sv_undef;
3883             }
3884         }
3885         else if (hvtype == SVt_PVAV) {                  /* array element */
3886             if (PL_op->op_flags & OPf_SPECIAL) {
3887                 while (++MARK <= SP) {
3888                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3889                     *MARK = sv ? sv : &PL_sv_undef;
3890                 }
3891             }
3892         }
3893         else
3894             DIE(aTHX_ "Not a HASH reference");
3895         if (discard)
3896             SP = ORIGMARK;
3897         else if (gimme == G_SCALAR) {
3898             MARK = ORIGMARK;
3899             *++MARK = *SP;
3900             SP = MARK;
3901         }
3902     }
3903     else {
3904         SV *keysv = POPs;
3905         hv = (HV*)POPs;
3906         if (SvTYPE(hv) == SVt_PVHV)
3907             sv = hv_delete_ent(hv, keysv, discard, 0);
3908         else if (SvTYPE(hv) == SVt_PVAV) {
3909             if (PL_op->op_flags & OPf_SPECIAL)
3910                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3911             else
3912                 DIE(aTHX_ "panic: avhv_delete no longer supported");
3913         }
3914         else
3915             DIE(aTHX_ "Not a HASH reference");
3916         if (!sv)
3917             sv = &PL_sv_undef;
3918         if (!discard)
3919             PUSHs(sv);
3920     }
3921     RETURN;
3922 }
3923
3924 PP(pp_exists)
3925 {
3926     dSP;
3927     SV *tmpsv;
3928     HV *hv;
3929
3930     if (PL_op->op_private & OPpEXISTS_SUB) {
3931         GV *gv;
3932         CV *cv;
3933         SV *sv = POPs;
3934         cv = sv_2cv(sv, &hv, &gv, FALSE);
3935         if (cv)
3936             RETPUSHYES;
3937         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3938             RETPUSHYES;
3939         RETPUSHNO;
3940     }
3941     tmpsv = POPs;
3942     hv = (HV*)POPs;
3943     if (SvTYPE(hv) == SVt_PVHV) {
3944         if (hv_exists_ent(hv, tmpsv, 0))
3945             RETPUSHYES;
3946     }
3947     else if (SvTYPE(hv) == SVt_PVAV) {
3948         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3949             if (av_exists((AV*)hv, SvIV(tmpsv)))
3950                 RETPUSHYES;
3951         }
3952     }
3953     else {
3954         DIE(aTHX_ "Not a HASH reference");
3955     }
3956     RETPUSHNO;
3957 }
3958
3959 PP(pp_hslice)
3960 {
3961     dSP; dMARK; dORIGMARK;
3962     register HV *hv = (HV*)POPs;
3963     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3964     bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3965     bool other_magic = FALSE;
3966
3967     if (localizing) {
3968         MAGIC *mg;
3969         HV *stash;
3970
3971         other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3972             ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3973              /* Try to preserve the existenceness of a tied hash
3974               * element by using EXISTS and DELETE if possible.
3975               * Fallback to FETCH and STORE otherwise */
3976              && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3977              && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3978              && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3979     }
3980
3981     while (++MARK <= SP) {
3982         SV *keysv = *MARK;
3983         SV **svp;
3984         HE *he;
3985         bool preeminent = FALSE;
3986
3987         if (localizing) {
3988             preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3989                 hv_exists_ent(hv, keysv, 0);
3990         }
3991
3992         he = hv_fetch_ent(hv, keysv, lval, 0);
3993         svp = he ? &HeVAL(he) : 0;
3994
3995         if (lval) {
3996             if (!svp || *svp == &PL_sv_undef) {
3997                 STRLEN n_a;
3998                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3999             }
4000             if (localizing) {
4001                 if (preeminent)
4002                     save_helem(hv, keysv, svp);
4003                 else {
4004                     STRLEN keylen;
4005                     char *key = SvPV(keysv, keylen);
4006                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
4007                 }
4008             }
4009         }
4010         *MARK = svp ? *svp : &PL_sv_undef;
4011     }
4012     if (GIMME != G_ARRAY) {
4013         MARK = ORIGMARK;
4014         *++MARK = *SP;
4015         SP = MARK;
4016     }
4017     RETURN;
4018 }
4019
4020 /* List operators. */
4021
4022 PP(pp_list)
4023 {
4024     dSP; dMARK;
4025     if (GIMME != G_ARRAY) {
4026         if (++MARK <= SP)
4027             *MARK = *SP;                /* unwanted list, return last item */
4028         else
4029             *MARK = &PL_sv_undef;
4030         SP = MARK;
4031     }
4032     RETURN;
4033 }
4034
4035 PP(pp_lslice)
4036 {
4037     dSP;
4038     SV **lastrelem = PL_stack_sp;
4039     SV **lastlelem = PL_stack_base + POPMARK;
4040     SV **firstlelem = PL_stack_base + POPMARK + 1;
4041     register SV **firstrelem = lastlelem + 1;
4042     I32 arybase = PL_curcop->cop_arybase;
4043     I32 lval = PL_op->op_flags & OPf_MOD;
4044     I32 is_something_there = lval;
4045
4046     register I32 max = lastrelem - lastlelem;
4047     register SV **lelem;
4048     register I32 ix;
4049
4050     if (GIMME != G_ARRAY) {
4051         ix = SvIVx(*lastlelem);
4052         if (ix < 0)
4053             ix += max;
4054         else
4055             ix -= arybase;
4056         if (ix < 0 || ix >= max)
4057             *firstlelem = &PL_sv_undef;
4058         else
4059             *firstlelem = firstrelem[ix];
4060         SP = firstlelem;
4061         RETURN;
4062     }
4063
4064     if (max == 0) {
4065         SP = firstlelem - 1;
4066         RETURN;
4067     }
4068
4069     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4070         ix = SvIVx(*lelem);
4071         if (ix < 0)
4072             ix += max;
4073         else
4074             ix -= arybase;
4075         if (ix < 0 || ix >= max)
4076             *lelem = &PL_sv_undef;
4077         else {
4078             is_something_there = TRUE;
4079             if (!(*lelem = firstrelem[ix]))
4080                 *lelem = &PL_sv_undef;
4081         }
4082     }
4083     if (is_something_there)
4084         SP = lastlelem;
4085     else
4086         SP = firstlelem - 1;
4087     RETURN;
4088 }
4089
4090 PP(pp_anonlist)
4091 {
4092     dSP; dMARK; dORIGMARK;
4093     I32 items = SP - MARK;
4094     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4095     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4096     XPUSHs(av);
4097     RETURN;
4098 }
4099
4100 PP(pp_anonhash)
4101 {
4102     dSP; dMARK; dORIGMARK;
4103     HV* hv = (HV*)sv_2mortal((SV*)newHV());
4104
4105     while (MARK < SP) {
4106         SV* key = *++MARK;
4107         SV *val = NEWSV(46, 0);
4108         if (MARK < SP)
4109             sv_setsv(val, *++MARK);
4110         else if (ckWARN(WARN_MISC))
4111             Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4112         (void)hv_store_ent(hv,key,val,0);
4113     }
4114     SP = ORIGMARK;
4115     XPUSHs((SV*)hv);
4116     RETURN;
4117 }
4118
4119 PP(pp_splice)
4120 {
4121     dSP; dMARK; dORIGMARK;
4122     register AV *ary = (AV*)*++MARK;
4123     register SV **src;
4124     register SV **dst;
4125     register I32 i;
4126     register I32 offset;
4127     register I32 length;
4128     I32 newlen;
4129     I32 after;
4130     I32 diff;
4131     SV **tmparyval = 0;
4132     MAGIC *mg;
4133
4134     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4135         *MARK-- = SvTIED_obj((SV*)ary, mg);
4136         PUSHMARK(MARK);
4137         PUTBACK;
4138         ENTER;
4139         call_method("SPLICE",GIMME_V);
4140         LEAVE;
4141         SPAGAIN;
4142         RETURN;
4143     }
4144
4145     SP++;
4146
4147     if (++MARK < SP) {
4148         offset = i = SvIVx(*MARK);
4149         if (offset < 0)
4150             offset += AvFILLp(ary) + 1;
4151         else
4152             offset -= PL_curcop->cop_arybase;
4153         if (offset < 0)
4154             DIE(aTHX_ PL_no_aelem, i);
4155         if (++MARK < SP) {
4156             length = SvIVx(*MARK++);
4157             if (length < 0) {
4158                 length += AvFILLp(ary) - offset + 1;
4159                 if (length < 0)
4160                     length = 0;
4161             }
4162         }
4163         else
4164             length = AvMAX(ary) + 1;            /* close enough to infinity */
4165     }
4166     else {
4167         offset = 0;
4168         length = AvMAX(ary) + 1;
4169     }
4170     if (offset > AvFILLp(ary) + 1) {
4171         if (ckWARN(WARN_MISC))
4172             Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4173         offset = AvFILLp(ary) + 1;
4174     }
4175     after = AvFILLp(ary) + 1 - (offset + length);
4176     if (after < 0) {                            /* not that much array */
4177         length += after;                        /* offset+length now in array */
4178         after = 0;
4179         if (!AvALLOC(ary))
4180             av_extend(ary, 0);
4181     }
4182
4183     /* At this point, MARK .. SP-1 is our new LIST */
4184
4185     newlen = SP - MARK;
4186     diff = newlen - length;
4187     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4188         av_reify(ary);
4189
4190     if (diff < 0) {                             /* shrinking the area */
4191         if (newlen) {
4192             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
4193             Copy(MARK, tmparyval, newlen, SV*);
4194         }
4195
4196         MARK = ORIGMARK + 1;
4197         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4198             MEXTEND(MARK, length);
4199             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4200             if (AvREAL(ary)) {
4201                 EXTEND_MORTAL(length);
4202                 for (i = length, dst = MARK; i; i--) {
4203                     sv_2mortal(*dst);   /* free them eventualy */
4204                     dst++;
4205                 }
4206             }
4207             MARK += length - 1;
4208         }
4209         else {
4210             *MARK = AvARRAY(ary)[offset+length-1];
4211             if (AvREAL(ary)) {
4212                 sv_2mortal(*MARK);
4213                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4214                     SvREFCNT_dec(*dst++);       /* free them now */
4215             }
4216         }
4217         AvFILLp(ary) += diff;
4218
4219         /* pull up or down? */
4220
4221         if (offset < after) {                   /* easier to pull up */
4222             if (offset) {                       /* esp. if nothing to pull */
4223                 src = &AvARRAY(ary)[offset-1];
4224                 dst = src - diff;               /* diff is negative */
4225                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4226                     *dst-- = *src--;
4227             }
4228             dst = AvARRAY(ary);
4229             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4230             AvMAX(ary) += diff;
4231         }
4232         else {
4233             if (after) {                        /* anything to pull down? */
4234                 src = AvARRAY(ary) + offset + length;
4235                 dst = src + diff;               /* diff is negative */
4236                 Move(src, dst, after, SV*);
4237             }
4238             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4239                                                 /* avoid later double free */
4240         }
4241         i = -diff;
4242         while (i)
4243             dst[--i] = &PL_sv_undef;
4244
4245         if (newlen) {
4246             for (src = tmparyval, dst = AvARRAY(ary) + offset;
4247               newlen; newlen--) {
4248                 *dst = NEWSV(46, 0);
4249                 sv_setsv(*dst++, *src++);
4250             }
4251             Safefree(tmparyval);
4252         }
4253     }
4254     else {                                      /* no, expanding (or same) */
4255         if (length) {
4256             New(452, tmparyval, length, SV*);   /* so remember deletion */
4257             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4258         }
4259
4260         if (diff > 0) {                         /* expanding */
4261
4262             /* push up or down? */
4263
4264             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4265                 if (offset) {
4266                     src = AvARRAY(ary);
4267                     dst = src - diff;
4268                     Move(src, dst, offset, SV*);
4269                 }
4270                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4271                 AvMAX(ary) += diff;
4272                 AvFILLp(ary) += diff;
4273             }
4274             else {
4275                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4276                     av_extend(ary, AvFILLp(ary) + diff);
4277                 AvFILLp(ary) += diff;
4278
4279                 if (after) {
4280                     dst = AvARRAY(ary) + AvFILLp(ary);
4281                     src = dst - diff;
4282                     for (i = after; i; i--) {
4283                         *dst-- = *src--;
4284                     }
4285                 }
4286             }
4287         }
4288
4289         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4290             *dst = NEWSV(46, 0);
4291             sv_setsv(*dst++, *src++);
4292         }
4293         MARK = ORIGMARK + 1;
4294         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4295             if (length) {
4296                 Copy(tmparyval, MARK, length, SV*);
4297                 if (AvREAL(ary)) {
4298                     EXTEND_MORTAL(length);
4299                     for (i = length, dst = MARK; i; i--) {
4300                         sv_2mortal(*dst);       /* free them eventualy */
4301                         dst++;
4302                     }
4303                 }
4304                 Safefree(tmparyval);
4305             }
4306             MARK += length - 1;
4307         }
4308         else if (length--) {
4309             *MARK = tmparyval[length];
4310             if (AvREAL(ary)) {
4311                 sv_2mortal(*MARK);
4312                 while (length-- > 0)
4313                     SvREFCNT_dec(tmparyval[length]);
4314             }
4315             Safefree(tmparyval);
4316         }
4317         else
4318             *MARK = &PL_sv_undef;
4319     }
4320     SP = MARK;
4321     RETURN;
4322 }
4323
4324 PP(pp_push)
4325 {
4326     dSP; dMARK; dORIGMARK; dTARGET;
4327     register AV *ary = (AV*)*++MARK;
4328     register SV *sv = &PL_sv_undef;
4329     MAGIC *mg;
4330
4331     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4332         *MARK-- = SvTIED_obj((SV*)ary, mg);
4333         PUSHMARK(MARK);
4334         PUTBACK;
4335         ENTER;
4336         call_method("PUSH",G_SCALAR|G_DISCARD);
4337         LEAVE;
4338         SPAGAIN;
4339     }
4340     else {
4341         /* Why no pre-extend of ary here ? */
4342         for (++MARK; MARK <= SP; MARK++) {
4343             sv = NEWSV(51, 0);
4344             if (*MARK)
4345                 sv_setsv(sv, *MARK);
4346             av_push(ary, sv);
4347         }
4348     }
4349     SP = ORIGMARK;
4350     PUSHi( AvFILL(ary) + 1 );
4351     RETURN;
4352 }
4353
4354 PP(pp_pop)
4355 {
4356     dSP;
4357     AV *av = (AV*)POPs;
4358     SV *sv = av_pop(av);
4359     if (AvREAL(av))
4360         (void)sv_2mortal(sv);
4361     PUSHs(sv);
4362     RETURN;
4363 }
4364
4365 PP(pp_shift)
4366 {
4367     dSP;
4368     AV *av = (AV*)POPs;
4369     SV *sv = av_shift(av);
4370     EXTEND(SP, 1);
4371     if (!sv)
4372         RETPUSHUNDEF;
4373     if (AvREAL(av))
4374         (void)sv_2mortal(sv);
4375     PUSHs(sv);
4376     RETURN;
4377 }
4378
4379 PP(pp_unshift)
4380 {
4381     dSP; dMARK; dORIGMARK; dTARGET;
4382     register AV *ary = (AV*)*++MARK;
4383     register SV *sv;
4384     register I32 i = 0;
4385     MAGIC *mg;
4386
4387     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4388         *MARK-- = SvTIED_obj((SV*)ary, mg);
4389         PUSHMARK(MARK);
4390         PUTBACK;
4391         ENTER;
4392         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4393         LEAVE;
4394         SPAGAIN;
4395     }
4396     else {
4397         av_unshift(ary, SP - MARK);
4398         while (MARK < SP) {
4399             sv = NEWSV(27, 0);
4400             sv_setsv(sv, *++MARK);
4401             (void)av_store(ary, i++, sv);
4402         }
4403     }
4404     SP = ORIGMARK;
4405     PUSHi( AvFILL(ary) + 1 );
4406     RETURN;
4407 }
4408
4409 PP(pp_reverse)
4410 {
4411     dSP; dMARK;
4412     register SV *tmp;
4413     SV **oldsp = SP;
4414
4415     if (GIMME == G_ARRAY) {
4416         MARK++;
4417         while (MARK < SP) {
4418             tmp = *MARK;
4419             *MARK++ = *SP;
4420             *SP-- = tmp;
4421         }
4422         /* safe as long as stack cannot get extended in the above */
4423         SP = oldsp;
4424     }
4425     else {
4426         register char *up;
4427         register char *down;
4428         register I32 tmp;
4429         dTARGET;
4430         STRLEN len;
4431
4432         SvUTF8_off(TARG);                               /* decontaminate */
4433         if (SP - MARK > 1)
4434             do_join(TARG, &PL_sv_no, MARK, SP);
4435         else
4436             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4437         up = SvPV_force(TARG, len);
4438         if (len > 1) {
4439             if (DO_UTF8(TARG)) {        /* first reverse each character */
4440                 U8* s = (U8*)SvPVX(TARG);
4441                 U8* send = (U8*)(s + len);
4442                 while (s < send) {
4443                     if (UTF8_IS_INVARIANT(*s)) {
4444                         s++;
4445                         continue;
4446                     }
4447                     else {
4448                         if (!utf8_to_uvchr(s, 0))
4449                             break;
4450                         up = (char*)s;
4451                         s += UTF8SKIP(s);
4452                         down = (char*)(s - 1);
4453                         /* reverse this character */
4454                         while (down > up) {
4455                             tmp = *up;
4456                             *up++ = *down;
4457                             *down-- = (char)tmp;
4458                         }
4459                     }
4460                 }
4461                 up = SvPVX(TARG);
4462             }
4463             down = SvPVX(TARG) + len - 1;
4464             while (down > up) {
4465                 tmp = *up;
4466                 *up++ = *down;
4467                 *down-- = (char)tmp;
4468             }
4469             (void)SvPOK_only_UTF8(TARG);
4470         }
4471         SP = MARK + 1;
4472         SETTARG;
4473     }
4474     RETURN;
4475 }
4476
4477 PP(pp_split)
4478 {
4479     dSP; dTARG;
4480     AV *ary;
4481     register IV limit = POPi;                   /* note, negative is forever */
4482     SV *sv = POPs;
4483     STRLEN len;
4484     register char *s = SvPV(sv, len);
4485     bool do_utf8 = DO_UTF8(sv);
4486     char *strend = s + len;
4487     register PMOP *pm;
4488     register REGEXP *rx;
4489     register SV *dstr;
4490     register char *m;
4491     I32 iters = 0;
4492     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4493     I32 maxiters = slen + 10;
4494     I32 i;
4495     char *orig;
4496     I32 origlimit = limit;
4497     I32 realarray = 0;
4498     I32 base;
4499     AV *oldstack = PL_curstack;
4500     I32 gimme = GIMME_V;
4501     I32 oldsave = PL_savestack_ix;
4502     I32 make_mortal = 1;
4503     MAGIC *mg = (MAGIC *) NULL;
4504
4505 #ifdef DEBUGGING
4506     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4507 #else
4508     pm = (PMOP*)POPs;
4509 #endif
4510     if (!pm || !s)
4511         DIE(aTHX_ "panic: pp_split");
4512     rx = PM_GETRE(pm);
4513
4514     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4515              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4516
4517     RX_MATCH_UTF8_set(rx, do_utf8);
4518
4519     if (pm->op_pmreplroot) {
4520 #ifdef USE_ITHREADS
4521         ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4522 #else
4523         ary = GvAVn((GV*)pm->op_pmreplroot);
4524 #endif
4525     }
4526     else if (gimme != G_ARRAY)
4527         ary = GvAVn(PL_defgv);
4528     else
4529         ary = Nullav;
4530     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4531         realarray = 1;
4532         PUTBACK;
4533         av_extend(ary,0);
4534         av_clear(ary);
4535         SPAGAIN;
4536         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4537             PUSHMARK(SP);
4538             XPUSHs(SvTIED_obj((SV*)ary, mg));
4539         }
4540         else {
4541             if (!AvREAL(ary)) {
4542                 AvREAL_on(ary);
4543                 AvREIFY_off(ary);
4544                 for (i = AvFILLp(ary); i >= 0; i--)
4545                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4546             }
4547             /* temporarily switch stacks */
4548             SWITCHSTACK(PL_curstack, ary);
4549             PL_curstackinfo->si_stack = ary;
4550             make_mortal = 0;
4551         }
4552     }
4553     base = SP - PL_stack_base;
4554     orig = s;
4555     if (pm->op_pmflags & PMf_SKIPWHITE) {
4556         if (pm->op_pmflags & PMf_LOCALE) {
4557             while (isSPACE_LC(*s))
4558                 s++;
4559         }
4560         else {
4561             while (isSPACE(*s))
4562                 s++;
4563         }
4564     }
4565     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4566         SAVEINT(PL_multiline);
4567         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4568     }
4569
4570     if (!limit)
4571         limit = maxiters + 2;
4572     if (pm->op_pmflags & PMf_WHITE) {
4573         while (--limit) {
4574             m = s;
4575             while (m < strend &&
4576                    !((pm->op_pmflags & PMf_LOCALE)
4577                      ? isSPACE_LC(*m) : isSPACE(*m)))
4578                 ++m;
4579             if (m >= strend)
4580                 break;
4581
4582             dstr = NEWSV(30, m-s);
4583             sv_setpvn(dstr, s, m-s);
4584             if (make_mortal)
4585                 sv_2mortal(dstr);
4586             if (do_utf8)
4587                 (void)SvUTF8_on(dstr);
4588             XPUSHs(dstr);
4589
4590             s = m + 1;
4591             while (s < strend &&
4592                    ((pm->op_pmflags & PMf_LOCALE)
4593                     ? isSPACE_LC(*s) : isSPACE(*s)))
4594                 ++s;
4595         }
4596     }
4597     else if (strEQ("^", rx->precomp)) {
4598         while (--limit) {
4599             /*SUPPRESS 530*/
4600             for (m = s; m < strend && *m != '\n'; m++) ;
4601             m++;
4602             if (m >= strend)
4603                 break;
4604             dstr = NEWSV(30, m-s);
4605             sv_setpvn(dstr, s, m-s);
4606             if (make_mortal)
4607                 sv_2mortal(dstr);
4608             if (do_utf8)
4609                 (void)SvUTF8_on(dstr);
4610             XPUSHs(dstr);
4611             s = m;
4612         }
4613     }
4614     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4615              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4616              && (rx->reganch & ROPT_CHECK_ALL)
4617              && !(rx->reganch & ROPT_ANCH)) {
4618         int tail = (rx->reganch & RE_INTUIT_TAIL);
4619         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4620
4621         len = rx->minlen;
4622         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4623             STRLEN n_a;
4624             char c = *SvPV(csv, n_a);
4625             while (--limit) {
4626                 /*SUPPRESS 530*/
4627                 for (m = s; m < strend && *m != c; m++) ;
4628                 if (m >= strend)
4629                     break;
4630                 dstr = NEWSV(30, m-s);
4631                 sv_setpvn(dstr, s, m-s);
4632                 if (make_mortal)
4633                     sv_2mortal(dstr);
4634                 if (do_utf8)
4635                     (void)SvUTF8_on(dstr);
4636                 XPUSHs(dstr);
4637                 /* The rx->minlen is in characters but we want to step
4638                  * s ahead by bytes. */
4639                 if (do_utf8)
4640                     s = (char*)utf8_hop((U8*)m, len);
4641                 else
4642                     s = m + len; /* Fake \n at the end */
4643             }
4644         }
4645         else {
4646 #ifndef lint
4647             while (s < strend && --limit &&
4648               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4649                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4650 #endif
4651             {
4652                 dstr = NEWSV(31, m-s);
4653                 sv_setpvn(dstr, s, m-s);
4654                 if (make_mortal)
4655                     sv_2mortal(dstr);
4656                 if (do_utf8)
4657                     (void)SvUTF8_on(dstr);
4658                 XPUSHs(dstr);
4659                 /* The rx->minlen is in characters but we want to step
4660                  * s ahead by bytes. */
4661                 if (do_utf8)
4662                     s = (char*)utf8_hop((U8*)m, len);
4663                 else
4664                     s = m + len; /* Fake \n at the end */
4665             }
4666         }
4667     }
4668     else {
4669         maxiters += slen * rx->nparens;
4670         while (s < strend && --limit
4671 /*             && (!rx->check_substr
4672                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4673                                                  0, NULL))))
4674 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4675                               1 /* minend */, sv, NULL, 0))
4676         {
4677             TAINT_IF(RX_MATCH_TAINTED(rx));
4678             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4679                 m = s;
4680                 s = orig;
4681                 orig = rx->subbeg;
4682                 s = orig + (m - s);
4683                 strend = s + (strend - m);
4684             }
4685             m = rx->startp[0] + orig;
4686             dstr = NEWSV(32, m-s);
4687             sv_setpvn(dstr, s, m-s);
4688             if (make_mortal)
4689                 sv_2mortal(dstr);
4690             if (do_utf8)
4691                 (void)SvUTF8_on(dstr);
4692             XPUSHs(dstr);
4693             if (rx->nparens) {
4694                 for (i = 1; i <= (I32)rx->nparens; i++) {
4695                     s = rx->startp[i] + orig;
4696                     m = rx->endp[i] + orig;
4697
4698                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
4699                        parens that didn't match -- they should be set to
4700                        undef, not the empty string */
4701                     if (m >= orig && s >= orig) {
4702                         dstr = NEWSV(33, m-s);
4703                         sv_setpvn(dstr, s, m-s);
4704                     }
4705                     else
4706                         dstr = &PL_sv_undef;  /* undef, not "" */
4707                     if (make_mortal)
4708                         sv_2mortal(dstr);
4709                     if (do_utf8)
4710                         (void)SvUTF8_on(dstr);
4711                     XPUSHs(dstr);
4712                 }
4713             }
4714             s = rx->endp[0] + orig;
4715             PUTBACK;
4716         }
4717     }
4718
4719     LEAVE_SCOPE(oldsave);
4720     iters = (SP - PL_stack_base) - base;
4721     if (iters > maxiters)
4722         DIE(aTHX_ "Split loop");
4723
4724     /* keep field after final delim? */
4725     if (s < strend || (iters && origlimit)) {
4726         STRLEN l = strend - s;
4727         dstr = NEWSV(34, l);
4728         sv_setpvn(dstr, s, l);
4729         if (make_mortal)
4730             sv_2mortal(dstr);
4731         if (do_utf8)
4732             (void)SvUTF8_on(dstr);
4733         XPUSHs(dstr);
4734         iters++;
4735     }
4736     else if (!origlimit) {
4737         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4738             if (TOPs && !make_mortal)
4739                 sv_2mortal(TOPs);
4740             iters--;
4741             SP--;
4742         }
4743     }
4744
4745     if (realarray) {
4746         if (!mg) {
4747             SWITCHSTACK(ary, oldstack);
4748             PL_curstackinfo->si_stack = oldstack;
4749             if (SvSMAGICAL(ary)) {
4750                 PUTBACK;
4751                 mg_set((SV*)ary);
4752                 SPAGAIN;
4753             }
4754             if (gimme == G_ARRAY) {
4755                 EXTEND(SP, iters);
4756                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4757                 SP += iters;
4758                 RETURN;
4759             }
4760         }
4761         else {
4762             PUTBACK;
4763             ENTER;
4764             call_method("PUSH",G_SCALAR|G_DISCARD);
4765             LEAVE;
4766             SPAGAIN;
4767             if (gimme == G_ARRAY) {
4768                 /* EXTEND should not be needed - we just popped them */
4769                 EXTEND(SP, iters);
4770                 for (i=0; i < iters; i++) {
4771                     SV **svp = av_fetch(ary, i, FALSE);
4772                     PUSHs((svp) ? *svp : &PL_sv_undef);
4773                 }
4774                 RETURN;
4775             }
4776         }
4777     }
4778     else {
4779         if (gimme == G_ARRAY)
4780             RETURN;
4781     }
4782
4783     GETTARGET;
4784     PUSHi(iters);
4785     RETURN;
4786 }
4787
4788 PP(pp_lock)
4789 {
4790     dSP;
4791     dTOPss;
4792     SV *retsv = sv;
4793     SvLOCK(sv);
4794     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4795         || SvTYPE(retsv) == SVt_PVCV) {
4796         retsv = refto(retsv);
4797     }
4798     SETs(retsv);
4799     RETURN;
4800 }
4801
4802 PP(pp_threadsv)
4803 {
4804     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4805 }