pp.c

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