pp.c

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