pp.c

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