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