pp.c

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