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     djSP;
  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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP;
 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     djSP; 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     djSP;
 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     djSP;
 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     djSP;
 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     djSP;
 491     *SP = refto(*SP);
 492     RETURN;
 493 }
 494
 495 PP(pp_refgen)
 496 {
 497     djSP; 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     djSP; 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     djSP;
 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     djSP;
 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     djSP; 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     djSP; 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     djSP; dTARGET;
 741     do_chop(TARG, TOPs);
 742     SETTARG;
 743     RETURN;
 744 }
 745
 746 PP(pp_chop)
 747 {
 748     djSP; dMARK; dTARGET;
 749     while (SP > MARK)
 750         do_chop(TARG, POPs);
 751     PUSHTARG;
 752     RETURN;
 753 }
 754
 755 PP(pp_schomp)
 756 {
 757     djSP; dTARGET;
 758     SETi(do_chomp(TOPs));
 759     RETURN;
 760 }
 761
 762 PP(pp_chomp)
 763 {
 764     djSP; 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     djSP;
 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     djSP;
 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     djSP;
 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     djSP; 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     djSP; 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     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
 932     {
 933       dPOPTOPnnrl;
 934       SETn( Perl_pow( left, right) );
 935       RETURN;
 936     }
 937 }
 938
 939 PP(pp_multiply)
 940 {
 941     djSP; 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     djSP; 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     djSP; 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   djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; tryAMAGICbinSET(seq,0);
1936     {
1937       dPOPTOPssrl;
1938       SETs(boolSV(sv_eq(left, right)));
1939       RETURN;
1940     }
1941 }
1942
1943 PP(pp_sne)
1944 {
1945     djSP; tryAMAGICbinSET(sne,0);
1946     {
1947       dPOPTOPssrl;
1948       SETs(boolSV(!sv_eq(left, right)));
1949       RETURN;
1950     }
1951 }
1952
1953 PP(pp_scmp)
1954 {
1955     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; tryAMAGICunSET(not);
2102     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2103     return NORMAL;
2104 }
2105
2106 PP(pp_complement)
2107 {
2108     djSP; 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     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2203     {
2204       dPOPTOPiirl;
2205       SETi( left * right );
2206       RETURN;
2207     }
2208 }
2209
2210 PP(pp_i_divide)
2211 {
2212     djSP; 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     djSP; 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     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2238     {
2239       dPOPTOPiirl_ul;
2240       SETi( left + right );
2241       RETURN;
2242     }
2243 }
2244
2245 PP(pp_i_subtract)
2246 {
2247     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2248     {
2249       dPOPTOPiirl_ul;
2250       SETi( left - right );
2251       RETURN;
2252     }
2253 }
2254
2255 PP(pp_i_lt)
2256 {
2257     djSP; tryAMAGICbinSET(lt,0);
2258     {
2259       dPOPTOPiirl;
2260       SETs(boolSV(left < right));
2261       RETURN;
2262     }
2263 }
2264
2265 PP(pp_i_gt)
2266 {
2267     djSP; tryAMAGICbinSET(gt,0);
2268     {
2269       dPOPTOPiirl;
2270       SETs(boolSV(left > right));
2271       RETURN;
2272     }
2273 }
2274
2275 PP(pp_i_le)
2276 {
2277     djSP; tryAMAGICbinSET(le,0);
2278     {
2279       dPOPTOPiirl;
2280       SETs(boolSV(left <= right));
2281       RETURN;
2282     }
2283 }
2284
2285 PP(pp_i_ge)
2286 {
2287     djSP; tryAMAGICbinSET(ge,0);
2288     {
2289       dPOPTOPiirl;
2290       SETs(boolSV(left >= right));
2291       RETURN;
2292     }
2293 }
2294
2295 PP(pp_i_eq)
2296 {
2297     djSP; tryAMAGICbinSET(eq,0);
2298     {
2299       dPOPTOPiirl;
2300       SETs(boolSV(left == right));
2301       RETURN;
2302     }
2303 }
2304
2305 PP(pp_i_ne)
2306 {
2307     djSP; tryAMAGICbinSET(ne,0);
2308     {
2309       dPOPTOPiirl;
2310       SETs(boolSV(left != right));
2311       RETURN;
2312     }
2313 }
2314
2315 PP(pp_i_ncmp)
2316 {
2317     djSP; 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     djSP; dTARGET; tryAMAGICun(neg);
2336     SETi(-TOPi);
2337     RETURN;
2338 }
2339
2340 /* High falutin' math. */
2341
2342 PP(pp_atan2)
2343 {
2344     djSP; dTARGET; tryAMAGICbin(atan2,0);
2345     {
2346       dPOPTOPnnrl;
2347       SETn(Perl_atan2(left, right));
2348       RETURN;
2349     }
2350 }
2351
2352 PP(pp_sin)
2353 {
2354     djSP; 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     djSP; 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     djSP; 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     djSP;
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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP;
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     djSP;
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     djSP;
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     djSP;
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     djSP; 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     djSP; 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     djSP;
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     djSP;
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     djSP;
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     djSP; 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     djSP; 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     djSP;
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     djSP; 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     djSP; 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     djSP; 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     djSP; 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     djSP;
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     djSP;
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     djSP; 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     djSP; 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     djSP;
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                         if (checksum > 32)
4741                             cdouble += (NV)aulong;
4742                         else
4743                             culong += aulong;
4744                     }
4745                 }
4746             }
4747             else {
4748                 EXTEND(SP, len);
4749                 EXTEND_MORTAL(len);
4750 #if LONGSIZE != SIZE32
4751                 if (unatint) {
4752                     unsigned long aulong;
4753                     while (len-- > 0) {
4754                         COPYNN(s, &aulong, sizeof(unsigned long));
4755                         s += sizeof(unsigned long);
4756                         sv = NEWSV(43, 0);
4757                         sv_setuv(sv, (UV)aulong);
4758                         PUSHs(sv_2mortal(sv));
4759                     }
4760                 }
4761                 else
4762 #endif
4763                 {
4764                     while (len-- > 0) {
4765                         COPY32(s, &aulong);
4766                         s += SIZE32;
4767 #ifdef HAS_NTOHL
4768                         if (datumtype == 'N')
4769                             aulong = PerlSock_ntohl(aulong);
4770 #endif
4771 #ifdef HAS_VTOHL
4772                         if (datumtype == 'V')
4773                             aulong = vtohl(aulong);
4774 #endif
4775                         sv = NEWSV(43, 0);
4776                         sv_setuv(sv, (UV)aulong);
4777                         PUSHs(sv_2mortal(sv));
4778                     }
4779                 }
4780             }
4781             break;
4782         case 'p':
4783             along = (strend - s) / sizeof(char*);
4784             if (len > along)
4785                 len = along;
4786             EXTEND(SP, len);
4787             EXTEND_MORTAL(len);
4788             while (len-- > 0) {
4789                 if (sizeof(char*) > strend - s)
4790                     break;
4791                 else {
4792                     Copy(s, &aptr, 1, char*);
4793                     s += sizeof(char*);
4794                 }
4795                 sv = NEWSV(44, 0);
4796                 if (aptr)
4797                     sv_setpv(sv, aptr);
4798                 PUSHs(sv_2mortal(sv));
4799             }
4800             break;
4801         case 'w':
4802             EXTEND(SP, len);
4803             EXTEND_MORTAL(len);
4804             {
4805                 UV auv = 0;
4806                 U32 bytes = 0;
4807
4808                 while ((len > 0) && (s < strend)) {
4809                     auv = (auv << 7) | (*s & 0x7f);
4810                     if (UTF8_IS_ASCII(*s++)) {
4811                         bytes = 0;
4812                         sv = NEWSV(40, 0);
4813                         sv_setuv(sv, auv);
4814                         PUSHs(sv_2mortal(sv));
4815                         len--;
4816                         auv = 0;
4817                     }
4818                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4819                         char *t;
4820                         STRLEN n_a;
4821
4822                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4823                         while (s < strend) {
4824                             sv = mul128(sv, *s & 0x7f);
4825                             if (!(*s++ & 0x80)) {
4826                                 bytes = 0;
4827                                 break;
4828                             }
4829                         }
4830                         t = SvPV(sv, n_a);
4831                         while (*t == '0')
4832                             t++;
4833                         sv_chop(sv, t);
4834                         PUSHs(sv_2mortal(sv));
4835                         len--;
4836                         auv = 0;
4837                     }
4838                 }
4839                 if ((s >= strend) && bytes)
4840                     DIE(aTHX_ "Unterminated compressed integer");
4841             }
4842             break;
4843         case 'P':
4844             EXTEND(SP, 1);
4845             if (sizeof(char*) > strend - s)
4846                 break;
4847             else {
4848                 Copy(s, &aptr, 1, char*);
4849                 s += sizeof(char*);
4850             }
4851             sv = NEWSV(44, 0);
4852             if (aptr)
4853                 sv_setpvn(sv, aptr, len);
4854             PUSHs(sv_2mortal(sv));
4855             break;
4856 #ifdef HAS_QUAD
4857         case 'q':
4858             along = (strend - s) / sizeof(Quad_t);
4859             if (len > along)
4860                 len = along;
4861             EXTEND(SP, len);
4862             EXTEND_MORTAL(len);
4863             while (len-- > 0) {
4864                 if (s + sizeof(Quad_t) > strend)
4865                     aquad = 0;
4866                 else {
4867                     Copy(s, &aquad, 1, Quad_t);
4868                     s += sizeof(Quad_t);
4869                 }
4870                 sv = NEWSV(42, 0);
4871                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4872                     sv_setiv(sv, (IV)aquad);
4873                 else
4874                     sv_setnv(sv, (NV)aquad);
4875                 PUSHs(sv_2mortal(sv));
4876             }
4877             break;
4878         case 'Q':
4879             along = (strend - s) / sizeof(Quad_t);
4880             if (len > along)
4881                 len = along;
4882             EXTEND(SP, len);
4883             EXTEND_MORTAL(len);
4884             while (len-- > 0) {
4885                 if (s + sizeof(Uquad_t) > strend)
4886                     auquad = 0;
4887                 else {
4888                     Copy(s, &auquad, 1, Uquad_t);
4889                     s += sizeof(Uquad_t);
4890                 }
4891                 sv = NEWSV(43, 0);
4892                 if (auquad <= UV_MAX)
4893                     sv_setuv(sv, (UV)auquad);
4894                 else
4895                     sv_setnv(sv, (NV)auquad);
4896                 PUSHs(sv_2mortal(sv));
4897             }
4898             break;
4899 #endif
4900         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4901         case 'f':
4902         case 'F':
4903             along = (strend - s) / sizeof(float);
4904             if (len > along)
4905                 len = along;
4906             if (checksum) {
4907                 while (len-- > 0) {
4908                     Copy(s, &afloat, 1, float);
4909                     s += sizeof(float);
4910                     cdouble += afloat;
4911                 }
4912             }
4913             else {
4914                 EXTEND(SP, len);
4915                 EXTEND_MORTAL(len);
4916                 while (len-- > 0) {
4917                     Copy(s, &afloat, 1, float);
4918                     s += sizeof(float);
4919                     sv = NEWSV(47, 0);
4920                     sv_setnv(sv, (NV)afloat);
4921                     PUSHs(sv_2mortal(sv));
4922                 }
4923             }
4924             break;
4925         case 'd':
4926         case 'D':
4927             along = (strend - s) / sizeof(double);
4928             if (len > along)
4929                 len = along;
4930             if (checksum) {
4931                 while (len-- > 0) {
4932                     Copy(s, &adouble, 1, double);
4933                     s += sizeof(double);
4934                     cdouble += adouble;
4935                 }
4936             }
4937             else {
4938                 EXTEND(SP, len);
4939                 EXTEND_MORTAL(len);
4940                 while (len-- > 0) {
4941                     Copy(s, &adouble, 1, double);
4942                     s += sizeof(double);
4943                     sv = NEWSV(48, 0);
4944                     sv_setnv(sv, (NV)adouble);
4945                     PUSHs(sv_2mortal(sv));
4946                 }
4947             }
4948             break;
4949         case 'u':
4950             /* MKS:
4951              * Initialise the decode mapping.  By using a table driven
4952              * algorithm, the code will be character-set independent
4953              * (and just as fast as doing character arithmetic)
4954              */
4955             if (PL_uudmap['M'] == 0) {
4956                 int i;
4957
4958                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4959                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4960                 /*
4961                  * Because ' ' and '`' map to the same value,
4962                  * we need to decode them both the same.
4963                  */
4964                 PL_uudmap[' '] = 0;
4965             }
4966
4967             along = (strend - s) * 3 / 4;
4968             sv = NEWSV(42, along);
4969             if (along)
4970                 SvPOK_on(sv);
4971             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4972                 I32 a, b, c, d;
4973                 char hunk[4];
4974
4975                 hunk[3] = '\0';
4976                 len = PL_uudmap[*(U8*)s++] & 077;
4977                 while (len > 0) {
4978                     if (s < strend && ISUUCHAR(*s))
4979                         a = PL_uudmap[*(U8*)s++] & 077;
4980                     else
4981                         a = 0;
4982                     if (s < strend && ISUUCHAR(*s))
4983                         b = PL_uudmap[*(U8*)s++] & 077;
4984                     else
4985                         b = 0;
4986                     if (s < strend && ISUUCHAR(*s))
4987                         c = PL_uudmap[*(U8*)s++] & 077;
4988                     else
4989                         c = 0;
4990                     if (s < strend && ISUUCHAR(*s))
4991                         d = PL_uudmap[*(U8*)s++] & 077;
4992                     else
4993                         d = 0;
4994                     hunk[0] = (a << 2) | (b >> 4);
4995                     hunk[1] = (b << 4) | (c >> 2);
4996                     hunk[2] = (c << 6) | d;
4997                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4998                     len -= 3;
4999                 }
5000                 if (*s == '\n')
5001                     s++;
5002                 else if (s[1] == '\n')          /* possible checksum byte */
5003                     s += 2;
5004             }
5005             XPUSHs(sv_2mortal(sv));
5006             break;
5007         }
5008         if (checksum) {
5009             sv = NEWSV(42, 0);
5010             if (strchr("fFdD", datumtype) ||
5011               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5012                 NV trouble;
5013
5014                 adouble = 1.0;
5015                 while (checksum >= 16) {
5016                     checksum -= 16;
5017                     adouble *= 65536.0;
5018                 }
5019                 while (checksum >= 4) {
5020                     checksum -= 4;
5021                     adouble *= 16.0;
5022                 }
5023                 while (checksum--)
5024                     adouble *= 2.0;
5025                 along = (1 << checksum) - 1;
5026                 while (cdouble < 0.0)
5027                     cdouble += adouble;
5028                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5029                 sv_setnv(sv, cdouble);
5030             }
5031             else {
5032                 if (checksum < 32) {
5033                     aulong = (1 << checksum) - 1;
5034                     culong &= aulong;
5035                 }
5036                 sv_setuv(sv, (UV)culong);
5037             }
5038             XPUSHs(sv_2mortal(sv));
5039             checksum = 0;
5040         }
5041     }
5042     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5043         PUSHs(&PL_sv_undef);
5044     RETURN;
5045 }
5046
5047 STATIC void
5048 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5049 {
5050     char hunk[5];
5051
5052     *hunk = PL_uuemap[len];
5053     sv_catpvn(sv, hunk, 1);
5054     hunk[4] = '\0';
5055     while (len > 2) {
5056         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5057         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5058         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5059         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5060         sv_catpvn(sv, hunk, 4);
5061         s += 3;
5062         len -= 3;
5063     }
5064     if (len > 0) {
5065         char r = (len > 1 ? s[1] : '\0');
5066         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5067         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5068         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5069         hunk[3] = PL_uuemap[0];
5070         sv_catpvn(sv, hunk, 4);
5071     }
5072     sv_catpvn(sv, "\n", 1);
5073 }
5074
5075 STATIC SV *
5076 S_is_an_int(pTHX_ char *s, STRLEN l)
5077 {
5078   STRLEN         n_a;
5079   SV             *result = newSVpvn(s, l);
5080   char           *result_c = SvPV(result, n_a); /* convenience */
5081   char           *out = result_c;
5082   bool            skip = 1;
5083   bool            ignore = 0;
5084
5085   while (*s) {
5086     switch (*s) {
5087     case ' ':
5088       break;
5089     case '+':
5090       if (!skip) {
5091         SvREFCNT_dec(result);
5092         return (NULL);
5093       }
5094       break;
5095     case '0':
5096     case '1':
5097     case '2':
5098     case '3':
5099     case '4':
5100     case '5':
5101     case '6':
5102     case '7':
5103     case '8':
5104     case '9':
5105       skip = 0;
5106       if (!ignore) {
5107         *(out++) = *s;
5108       }
5109       break;
5110     case '.':
5111       ignore = 1;
5112       break;
5113     default:
5114       SvREFCNT_dec(result);
5115       return (NULL);
5116     }
5117     s++;
5118   }
5119   *(out++) = '\0';
5120   SvCUR_set(result, out - result_c);
5121   return (result);
5122 }
5123
5124 /* pnum must be '\0' terminated */
5125 STATIC int
5126 S_div128(pTHX_ SV *pnum, bool *done)
5127 {
5128   STRLEN          len;
5129   char           *s = SvPV(pnum, len);
5130   int             m = 0;
5131   int             r = 0;
5132   char           *t = s;
5133
5134   *done = 1;
5135   while (*t) {
5136     int             i;
5137
5138     i = m * 10 + (*t - '0');
5139     m = i & 0x7F;
5140     r = (i >> 7);               /* r < 10 */
5141     if (r) {
5142       *done = 0;
5143     }
5144     *(t++) = '0' + r;
5145   }
5146   *(t++) = '\0';
5147   SvCUR_set(pnum, (STRLEN) (t - s));
5148   return (m);
5149 }
5150
5151
5152 PP(pp_pack)
5153 {
5154     djSP; dMARK; dORIGMARK; dTARGET;
5155     register SV *cat = TARG;
5156     register I32 items;
5157     STRLEN fromlen;
5158     register char *pat = SvPVx(*++MARK, fromlen);
5159     char *patcopy;
5160     register char *patend = pat + fromlen;
5161     register I32 len;
5162     I32 datumtype;
5163     SV *fromstr;
5164     /*SUPPRESS 442*/
5165     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5166     static char *space10 = "          ";
5167
5168     /* These must not be in registers: */
5169     char achar;
5170     I16 ashort;
5171     int aint;
5172     unsigned int auint;
5173     I32 along;
5174     U32 aulong;
5175     UV auv;
5176 #ifdef HAS_QUAD
5177     Quad_t aquad;
5178     Uquad_t auquad;
5179 #endif
5180     char *aptr;
5181     float afloat;
5182     double adouble;
5183     int commas = 0;
5184 #ifdef PERL_NATINT_PACK
5185     int natint;         /* native integer */
5186 #endif
5187     bool has_utf8;
5188
5189     items = SP - MARK;
5190     MARK++;
5191     sv_setpvn(cat, "", 0);
5192     patcopy = pat;
5193     while (pat < patend) {
5194         SV *lengthcode = Nullsv;
5195 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5196         datumtype = *pat++ & 0xFF;
5197 #ifdef PERL_NATINT_PACK
5198         natint = 0;
5199 #endif
5200         if (isSPACE(datumtype)) {
5201             patcopy++;
5202             continue;
5203         }
5204         if (datumtype == 'U' && pat == patcopy+1)
5205             SvUTF8_on(cat);
5206         if (datumtype == '#') {
5207             while (pat < patend && *pat != '\n')
5208                 pat++;
5209             continue;
5210         }
5211         if (*pat == '!') {
5212             char *natstr = "sSiIlL";
5213
5214             if (strchr(natstr, datumtype)) {
5215 #ifdef PERL_NATINT_PACK
5216                 natint = 1;
5217 #endif
5218                 pat++;
5219             }
5220             else
5221                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5222         }
5223         if (*pat == '*') {
5224             len = strchr("@Xxu", datumtype) ? 0 : items;
5225             pat++;
5226         }
5227         else if (isDIGIT(*pat)) {
5228             len = *pat++ - '0';
5229             while (isDIGIT(*pat)) {
5230                 len = (len * 10) + (*pat++ - '0');
5231                 if (len < 0)
5232                     DIE(aTHX_ "Repeat count in pack overflows");
5233             }
5234         }
5235         else
5236             len = 1;
5237         if (*pat == '/') {
5238             ++pat;
5239             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5240                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5241             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5242                                                    ? *MARK : &PL_sv_no)
5243                                             + (*pat == 'Z' ? 1 : 0)));
5244         }
5245         switch(datumtype) {
5246         default:
5247             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5248         case ',': /* grandfather in commas but with a warning */
5249             if (commas++ == 0 && ckWARN(WARN_PACK))
5250                 Perl_warner(aTHX_ WARN_PACK,
5251                             "Invalid type in pack: '%c'", (int)datumtype);
5252             break;
5253         case '%':
5254             DIE(aTHX_ "%% may only be used in unpack");
5255         case '@':
5256             len -= SvCUR(cat);
5257             if (len > 0)
5258                 goto grow;
5259             len = -len;
5260             if (len > 0)
5261                 goto shrink;
5262             break;
5263         case 'X':
5264           shrink:
5265             if (SvCUR(cat) < len)
5266                 DIE(aTHX_ "X outside of string");
5267             SvCUR(cat) -= len;
5268             *SvEND(cat) = '\0';
5269             break;
5270         case 'x':
5271           grow:
5272             while (len >= 10) {
5273                 sv_catpvn(cat, null10, 10);
5274                 len -= 10;
5275             }
5276             sv_catpvn(cat, null10, len);
5277             break;
5278         case 'A':
5279         case 'Z':
5280         case 'a':
5281             fromstr = NEXTFROM;
5282             aptr = SvPV(fromstr, fromlen);
5283             if (pat[-1] == '*') {
5284                 len = fromlen;
5285                 if (datumtype == 'Z')
5286                     ++len;
5287             }
5288             if (fromlen >= len) {
5289                 sv_catpvn(cat, aptr, len);
5290                 if (datumtype == 'Z')
5291                     *(SvEND(cat)-1) = '\0';
5292             }
5293             else {
5294                 sv_catpvn(cat, aptr, fromlen);
5295                 len -= fromlen;
5296                 if (datumtype == 'A') {
5297                     while (len >= 10) {
5298                         sv_catpvn(cat, space10, 10);
5299                         len -= 10;
5300                     }
5301                     sv_catpvn(cat, space10, len);
5302                 }
5303                 else {
5304                     while (len >= 10) {
5305                         sv_catpvn(cat, null10, 10);
5306                         len -= 10;
5307                     }
5308                     sv_catpvn(cat, null10, len);
5309                 }
5310             }
5311             break;
5312         case 'B':
5313         case 'b':
5314             {
5315                 register char *str;
5316                 I32 saveitems;
5317
5318                 fromstr = NEXTFROM;
5319                 saveitems = items;
5320                 str = SvPV(fromstr, fromlen);
5321                 if (pat[-1] == '*')
5322                     len = fromlen;
5323                 aint = SvCUR(cat);
5324                 SvCUR(cat) += (len+7)/8;
5325                 SvGROW(cat, SvCUR(cat) + 1);
5326                 aptr = SvPVX(cat) + aint;
5327                 if (len > fromlen)
5328                     len = fromlen;
5329                 aint = len;
5330                 items = 0;
5331                 if (datumtype == 'B') {
5332                     for (len = 0; len++ < aint;) {
5333                         items |= *str++ & 1;
5334                         if (len & 7)
5335                             items <<= 1;
5336                         else {
5337                             *aptr++ = items & 0xff;
5338                             items = 0;
5339                         }
5340                     }
5341                 }
5342                 else {
5343                     for (len = 0; len++ < aint;) {
5344                         if (*str++ & 1)
5345                             items |= 128;
5346                         if (len & 7)
5347                             items >>= 1;
5348                         else {
5349                             *aptr++ = items & 0xff;
5350                             items = 0;
5351                         }
5352                     }
5353                 }
5354                 if (aint & 7) {
5355                     if (datumtype == 'B')
5356                         items <<= 7 - (aint & 7);
5357                     else
5358                         items >>= 7 - (aint & 7);
5359                     *aptr++ = items & 0xff;
5360                 }
5361                 str = SvPVX(cat) + SvCUR(cat);
5362                 while (aptr <= str)
5363                     *aptr++ = '\0';
5364
5365                 items = saveitems;
5366             }
5367             break;
5368         case 'H':
5369         case 'h':
5370             {
5371                 register char *str;
5372                 I32 saveitems;
5373
5374                 fromstr = NEXTFROM;
5375                 saveitems = items;
5376                 str = SvPV(fromstr, fromlen);
5377                 if (pat[-1] == '*')
5378                     len = fromlen;
5379                 aint = SvCUR(cat);
5380                 SvCUR(cat) += (len+1)/2;
5381                 SvGROW(cat, SvCUR(cat) + 1);
5382                 aptr = SvPVX(cat) + aint;
5383                 if (len > fromlen)
5384                     len = fromlen;
5385                 aint = len;
5386                 items = 0;
5387                 if (datumtype == 'H') {
5388                     for (len = 0; len++ < aint;) {
5389                         if (isALPHA(*str))
5390                             items |= ((*str++ & 15) + 9) & 15;
5391                         else
5392                             items |= *str++ & 15;
5393                         if (len & 1)
5394                             items <<= 4;
5395                         else {
5396                             *aptr++ = items & 0xff;
5397                             items = 0;
5398                         }
5399                     }
5400                 }
5401                 else {
5402                     for (len = 0; len++ < aint;) {
5403                         if (isALPHA(*str))
5404                             items |= (((*str++ & 15) + 9) & 15) << 4;
5405                         else
5406                             items |= (*str++ & 15) << 4;
5407                         if (len & 1)
5408                             items >>= 4;
5409                         else {
5410                             *aptr++ = items & 0xff;
5411                             items = 0;
5412                         }
5413                     }
5414                 }
5415                 if (aint & 1)
5416                     *aptr++ = items & 0xff;
5417                 str = SvPVX(cat) + SvCUR(cat);
5418                 while (aptr <= str)
5419                     *aptr++ = '\0';
5420
5421                 items = saveitems;
5422             }
5423             break;
5424         case 'c':
5425             while (len-- > 0) {
5426                 fromstr = NEXTFROM;
5427                 aint = SvIV(fromstr);
5428                 achar = aint;
5429                 sv_catpvn(cat, &achar, sizeof(char));
5430             }
5431             break;
5432         case 'C':
5433             has_utf8 = SvUTF8(cat);
5434             while (len-- > 0) {
5435                 fromstr = NEXTFROM;
5436                 auv = SvUV(fromstr);
5437                 if (!has_utf8 && auv > 0xFF && !IN_BYTE) {
5438                     has_utf8 = TRUE;
5439                     if (SvCUR(cat))
5440                         sv_utf8_upgrade(cat);
5441                     else
5442                         SvUTF8_on(cat); /* There will be UTF8. */
5443                 }
5444                 if (has_utf8) {
5445                     SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5446                     SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5447                                    - SvPVX(cat));
5448                 }
5449                 else {
5450                     achar = auv;
5451                     sv_catpvn(cat, &achar, sizeof(char));
5452                 }
5453             }
5454             *SvEND(cat) = '\0';
5455             break;
5456         case 'U':
5457             has_utf8 = SvUTF8(cat);
5458             while (len-- > 0) {
5459                 fromstr = NEXTFROM;
5460                 auv = SvUV(fromstr);
5461                 if (!has_utf8 && auv > 0x80) {
5462                     has_utf8 = TRUE;
5463                     sv_utf8_upgrade(cat);
5464                 }
5465                 SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5466                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5467                                - SvPVX(cat));
5468             }
5469             *SvEND(cat) = '\0';
5470             break;
5471         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5472         case 'f':
5473         case 'F':
5474             while (len-- > 0) {
5475                 fromstr = NEXTFROM;
5476                 afloat = (float)SvNV(fromstr);
5477                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5478             }
5479             break;
5480         case 'd':
5481         case 'D':
5482             while (len-- > 0) {
5483                 fromstr = NEXTFROM;
5484                 adouble = (double)SvNV(fromstr);
5485                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5486             }
5487             break;
5488         case 'n':
5489             while (len-- > 0) {
5490                 fromstr = NEXTFROM;
5491                 ashort = (I16)SvIV(fromstr);
5492 #ifdef HAS_HTONS
5493                 ashort = PerlSock_htons(ashort);
5494 #endif
5495                 CAT16(cat, &ashort);
5496             }
5497             break;
5498         case 'v':
5499             while (len-- > 0) {
5500                 fromstr = NEXTFROM;
5501                 ashort = (I16)SvIV(fromstr);
5502 #ifdef HAS_HTOVS
5503                 ashort = htovs(ashort);
5504 #endif
5505                 CAT16(cat, &ashort);
5506             }
5507             break;
5508         case 'S':
5509 #if SHORTSIZE != SIZE16
5510             if (natint) {
5511                 unsigned short aushort;
5512
5513                 while (len-- > 0) {
5514                     fromstr = NEXTFROM;
5515                     aushort = SvUV(fromstr);
5516                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5517                 }
5518             }
5519             else
5520 #endif
5521             {
5522                 U16 aushort;
5523
5524                 while (len-- > 0) {
5525                     fromstr = NEXTFROM;
5526                     aushort = (U16)SvUV(fromstr);
5527                     CAT16(cat, &aushort);
5528                 }
5529
5530             }
5531             break;
5532         case 's':
5533 #if SHORTSIZE != SIZE16
5534             if (natint) {
5535                 short ashort;
5536
5537                 while (len-- > 0) {
5538                     fromstr = NEXTFROM;
5539                     ashort = SvIV(fromstr);
5540                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5541                 }
5542             }
5543             else
5544 #endif
5545             {
5546                 while (len-- > 0) {
5547                     fromstr = NEXTFROM;
5548                     ashort = (I16)SvIV(fromstr);
5549                     CAT16(cat, &ashort);
5550                 }
5551             }
5552             break;
5553         case 'I':
5554             while (len-- > 0) {
5555                 fromstr = NEXTFROM;
5556                 auint = SvUV(fromstr);
5557                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5558             }
5559             break;
5560         case 'w':
5561             while (len-- > 0) {
5562                 fromstr = NEXTFROM;
5563                 adouble = Perl_floor(SvNV(fromstr));
5564
5565                 if (adouble < 0)
5566                     DIE(aTHX_ "Cannot compress negative numbers");
5567
5568                 if (
5569 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5570                     adouble <= 0xffffffff
5571 #else
5572 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5573                     adouble <= UV_MAX_cxux
5574 #   else
5575                     adouble <= UV_MAX
5576 #   endif
5577 #endif
5578                     )
5579                 {
5580                     char   buf[1 + sizeof(UV)];
5581                     char  *in = buf + sizeof(buf);
5582                     UV     auv = U_V(adouble);
5583
5584                     do {
5585                         *--in = (auv & 0x7f) | 0x80;
5586                         auv >>= 7;
5587                     } while (auv);
5588                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5589                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5590                 }
5591                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5592                     char           *from, *result, *in;
5593                     SV             *norm;
5594                     STRLEN          len;
5595                     bool            done;
5596
5597                     /* Copy string and check for compliance */
5598                     from = SvPV(fromstr, len);
5599                     if ((norm = is_an_int(from, len)) == NULL)
5600                         DIE(aTHX_ "can compress only unsigned integer");
5601
5602                     New('w', result, len, char);
5603                     in = result + len;
5604                     done = FALSE;
5605                     while (!done)
5606                         *--in = div128(norm, &done) | 0x80;
5607                     result[len - 1] &= 0x7F; /* clear continue bit */
5608                     sv_catpvn(cat, in, (result + len) - in);
5609                     Safefree(result);
5610                     SvREFCNT_dec(norm); /* free norm */
5611                 }
5612                 else if (SvNOKp(fromstr)) {
5613                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5614                     char  *in = buf + sizeof(buf);
5615
5616                     do {
5617                         double next = floor(adouble / 128);
5618                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5619                         if (in <= buf)  /* this cannot happen ;-) */
5620                             DIE(aTHX_ "Cannot compress integer");
5621                         in--;
5622                         adouble = next;
5623                     } while (adouble > 0);
5624                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5625                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5626                 }
5627                 else
5628                     DIE(aTHX_ "Cannot compress non integer");
5629             }
5630             break;
5631         case 'i':
5632             while (len-- > 0) {
5633                 fromstr = NEXTFROM;
5634                 aint = SvIV(fromstr);
5635                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5636             }
5637             break;
5638         case 'N':
5639             while (len-- > 0) {
5640                 fromstr = NEXTFROM;
5641                 aulong = SvUV(fromstr);
5642 #ifdef HAS_HTONL
5643                 aulong = PerlSock_htonl(aulong);
5644 #endif
5645                 CAT32(cat, &aulong);
5646             }
5647             break;
5648         case 'V':
5649             while (len-- > 0) {
5650                 fromstr = NEXTFROM;
5651                 aulong = SvUV(fromstr);
5652 #ifdef HAS_HTOVL
5653                 aulong = htovl(aulong);
5654 #endif
5655                 CAT32(cat, &aulong);
5656             }
5657             break;
5658         case 'L':
5659 #if LONGSIZE != SIZE32
5660             if (natint) {
5661                 unsigned long aulong;
5662
5663                 while (len-- > 0) {
5664                     fromstr = NEXTFROM;
5665                     aulong = SvUV(fromstr);
5666                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5667                 }
5668             }
5669             else
5670 #endif
5671             {
5672                 while (len-- > 0) {
5673                     fromstr = NEXTFROM;
5674                     aulong = SvUV(fromstr);
5675                     CAT32(cat, &aulong);
5676                 }
5677             }
5678             break;
5679         case 'l':
5680 #if LONGSIZE != SIZE32
5681             if (natint) {
5682                 long along;
5683
5684                 while (len-- > 0) {
5685                     fromstr = NEXTFROM;
5686                     along = SvIV(fromstr);
5687                     sv_catpvn(cat, (char *)&along, sizeof(long));
5688                 }
5689             }
5690             else
5691 #endif
5692             {
5693                 while (len-- > 0) {
5694                     fromstr = NEXTFROM;
5695                     along = SvIV(fromstr);
5696                     CAT32(cat, &along);
5697                 }
5698             }
5699             break;
5700 #ifdef HAS_QUAD
5701         case 'Q':
5702             while (len-- > 0) {
5703                 fromstr = NEXTFROM;
5704                 auquad = (Uquad_t)SvUV(fromstr);
5705                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5706             }
5707             break;
5708         case 'q':
5709             while (len-- > 0) {
5710                 fromstr = NEXTFROM;
5711                 aquad = (Quad_t)SvIV(fromstr);
5712                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5713             }
5714             break;
5715 #endif
5716         case 'P':
5717             len = 1;            /* assume SV is correct length */
5718             /* FALL THROUGH */
5719         case 'p':
5720             while (len-- > 0) {
5721                 fromstr = NEXTFROM;
5722                 if (fromstr == &PL_sv_undef)
5723                     aptr = NULL;
5724                 else {
5725                     STRLEN n_a;
5726                     /* XXX better yet, could spirit away the string to
5727                      * a safe spot and hang on to it until the result
5728                      * of pack() (and all copies of the result) are
5729                      * gone.
5730                      */
5731                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5732                                                 || (SvPADTMP(fromstr)
5733                                                     && !SvREADONLY(fromstr))))
5734                     {
5735                         Perl_warner(aTHX_ WARN_PACK,
5736                                 "Attempt to pack pointer to temporary value");
5737                     }
5738                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5739                         aptr = SvPV(fromstr,n_a);
5740                     else
5741                         aptr = SvPV_force(fromstr,n_a);
5742                 }
5743                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5744             }
5745             break;
5746         case 'u':
5747             fromstr = NEXTFROM;
5748             aptr = SvPV(fromstr, fromlen);
5749             SvGROW(cat, fromlen * 4 / 3);
5750             if (len <= 1)
5751                 len = 45;
5752             else
5753                 len = len / 3 * 3;
5754             while (fromlen > 0) {
5755                 I32 todo;
5756
5757                 if (fromlen > len)
5758                     todo = len;
5759                 else
5760                     todo = fromlen;
5761                 doencodes(cat, aptr, todo);
5762                 fromlen -= todo;
5763                 aptr += todo;
5764             }
5765             break;
5766         }
5767     }
5768     SvSETMAGIC(cat);
5769     SP = ORIGMARK;
5770     PUSHs(cat);
5771     RETURN;
5772 }
5773 #undef NEXTFROM
5774
5775
5776 PP(pp_split)
5777 {
5778     djSP; dTARG;
5779     AV *ary;
5780     register IV limit = POPi;                   /* note, negative is forever */
5781     SV *sv = POPs;
5782     STRLEN len;
5783     register char *s = SvPV(sv, len);
5784     bool do_utf8 = DO_UTF8(sv);
5785     char *strend = s + len;
5786     register PMOP *pm;
5787     register REGEXP *rx;
5788     register SV *dstr;
5789     register char *m;
5790     I32 iters = 0;
5791     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5792     I32 maxiters = slen + 10;
5793     I32 i;
5794     char *orig;
5795     I32 origlimit = limit;
5796     I32 realarray = 0;
5797     I32 base;
5798     AV *oldstack = PL_curstack;
5799     I32 gimme = GIMME_V;
5800     I32 oldsave = PL_savestack_ix;
5801     I32 make_mortal = 1;
5802     MAGIC *mg = (MAGIC *) NULL;
5803
5804 #ifdef DEBUGGING
5805     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5806 #else
5807     pm = (PMOP*)POPs;
5808 #endif
5809     if (!pm || !s)
5810         DIE(aTHX_ "panic: pp_split");
5811     rx = pm->op_pmregexp;
5812
5813     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5814              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5815
5816     if (pm->op_pmreplroot) {
5817 #ifdef USE_ITHREADS
5818         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5819 #else
5820         ary = GvAVn((GV*)pm->op_pmreplroot);
5821 #endif
5822     }
5823     else if (gimme != G_ARRAY)
5824 #ifdef USE_THREADS
5825         ary = (AV*)PL_curpad[0];
5826 #else
5827         ary = GvAVn(PL_defgv);
5828 #endif /* USE_THREADS */
5829     else
5830         ary = Nullav;
5831     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5832         realarray = 1;
5833         PUTBACK;
5834         av_extend(ary,0);
5835         av_clear(ary);
5836         SPAGAIN;
5837         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5838             PUSHMARK(SP);
5839             XPUSHs(SvTIED_obj((SV*)ary, mg));
5840         }
5841         else {
5842             if (!AvREAL(ary)) {
5843                 AvREAL_on(ary);
5844                 AvREIFY_off(ary);
5845                 for (i = AvFILLp(ary); i >= 0; i--)
5846                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5847             }
5848             /* temporarily switch stacks */
5849             SWITCHSTACK(PL_curstack, ary);
5850             make_mortal = 0;
5851         }
5852     }
5853     base = SP - PL_stack_base;
5854     orig = s;
5855     if (pm->op_pmflags & PMf_SKIPWHITE) {
5856         if (pm->op_pmflags & PMf_LOCALE) {
5857             while (isSPACE_LC(*s))
5858                 s++;
5859         }
5860         else {
5861             while (isSPACE(*s))
5862                 s++;
5863         }
5864     }
5865     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5866         SAVEINT(PL_multiline);
5867         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5868     }
5869
5870     if (!limit)
5871         limit = maxiters + 2;
5872     if (pm->op_pmflags & PMf_WHITE) {
5873         while (--limit) {
5874             m = s;
5875             while (m < strend &&
5876                    !((pm->op_pmflags & PMf_LOCALE)
5877                      ? isSPACE_LC(*m) : isSPACE(*m)))
5878                 ++m;
5879             if (m >= strend)
5880                 break;
5881
5882             dstr = NEWSV(30, m-s);
5883             sv_setpvn(dstr, s, m-s);
5884             if (make_mortal)
5885                 sv_2mortal(dstr);
5886             if (do_utf8)
5887                 (void)SvUTF8_on(dstr);
5888             XPUSHs(dstr);
5889
5890             s = m + 1;
5891             while (s < strend &&
5892                    ((pm->op_pmflags & PMf_LOCALE)
5893                     ? isSPACE_LC(*s) : isSPACE(*s)))
5894                 ++s;
5895         }
5896     }
5897     else if (strEQ("^", rx->precomp)) {
5898         while (--limit) {
5899             /*SUPPRESS 530*/
5900             for (m = s; m < strend && *m != '\n'; m++) ;
5901             m++;
5902             if (m >= strend)
5903                 break;
5904             dstr = NEWSV(30, m-s);
5905             sv_setpvn(dstr, s, m-s);
5906             if (make_mortal)
5907                 sv_2mortal(dstr);
5908             if (do_utf8)
5909                 (void)SvUTF8_on(dstr);
5910             XPUSHs(dstr);
5911             s = m;
5912         }
5913     }
5914     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5915              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5916              && (rx->reganch & ROPT_CHECK_ALL)
5917              && !(rx->reganch & ROPT_ANCH)) {
5918         int tail = (rx->reganch & RE_INTUIT_TAIL);
5919         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5920
5921         len = rx->minlen;
5922         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5923             STRLEN n_a;
5924             char c = *SvPV(csv, n_a);
5925             while (--limit) {
5926                 /*SUPPRESS 530*/
5927                 for (m = s; m < strend && *m != c; m++) ;
5928                 if (m >= strend)
5929                     break;
5930                 dstr = NEWSV(30, m-s);
5931                 sv_setpvn(dstr, s, m-s);
5932                 if (make_mortal)
5933                     sv_2mortal(dstr);
5934                 if (do_utf8)
5935                     (void)SvUTF8_on(dstr);
5936                 XPUSHs(dstr);
5937                 /* The rx->minlen is in characters but we want to step
5938                  * s ahead by bytes. */
5939                 if (do_utf8)
5940                     s = (char*)utf8_hop((U8*)m, len);
5941                 else
5942                     s = m + len; /* Fake \n at the end */
5943             }
5944         }
5945         else {
5946 #ifndef lint
5947             while (s < strend && --limit &&
5948               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5949                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5950 #endif
5951             {
5952                 dstr = NEWSV(31, m-s);
5953                 sv_setpvn(dstr, s, m-s);
5954                 if (make_mortal)
5955                     sv_2mortal(dstr);
5956                 if (do_utf8)
5957                     (void)SvUTF8_on(dstr);
5958                 XPUSHs(dstr);
5959                 /* The rx->minlen is in characters but we want to step
5960                  * s ahead by bytes. */
5961                 if (do_utf8)
5962                     s = (char*)utf8_hop((U8*)m, len);
5963                 else
5964                     s = m + len; /* Fake \n at the end */
5965             }
5966         }
5967     }
5968     else {
5969         maxiters += slen * rx->nparens;
5970         while (s < strend && --limit
5971 /*             && (!rx->check_substr
5972                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5973                                                  0, NULL))))
5974 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5975                               1 /* minend */, sv, NULL, 0))
5976         {
5977             TAINT_IF(RX_MATCH_TAINTED(rx));
5978             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5979                 m = s;
5980                 s = orig;
5981                 orig = rx->subbeg;
5982                 s = orig + (m - s);
5983                 strend = s + (strend - m);
5984             }
5985             m = rx->startp[0] + orig;
5986             dstr = NEWSV(32, m-s);
5987             sv_setpvn(dstr, s, m-s);
5988             if (make_mortal)
5989                 sv_2mortal(dstr);
5990             if (do_utf8)
5991                 (void)SvUTF8_on(dstr);
5992             XPUSHs(dstr);
5993             if (rx->nparens) {
5994                 for (i = 1; i <= rx->nparens; i++) {
5995                     s = rx->startp[i] + orig;
5996                     m = rx->endp[i] + orig;
5997                     if (m && s) {
5998                         dstr = NEWSV(33, m-s);
5999                         sv_setpvn(dstr, s, m-s);
6000                     }
6001                     else
6002                         dstr = NEWSV(33, 0);
6003                     if (make_mortal)
6004                         sv_2mortal(dstr);
6005                     if (do_utf8)
6006                         (void)SvUTF8_on(dstr);
6007                     XPUSHs(dstr);
6008                 }
6009             }
6010             s = rx->endp[0] + orig;
6011         }
6012     }
6013
6014     LEAVE_SCOPE(oldsave);
6015     iters = (SP - PL_stack_base) - base;
6016     if (iters > maxiters)
6017         DIE(aTHX_ "Split loop");
6018
6019     /* keep field after final delim? */
6020     if (s < strend || (iters && origlimit)) {
6021         STRLEN l = strend - s;
6022         dstr = NEWSV(34, l);
6023         sv_setpvn(dstr, s, l);
6024         if (make_mortal)
6025             sv_2mortal(dstr);
6026         if (do_utf8)
6027             (void)SvUTF8_on(dstr);
6028         XPUSHs(dstr);
6029         iters++;
6030     }
6031     else if (!origlimit) {
6032         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6033             iters--, SP--;
6034     }
6035
6036     if (realarray) {
6037         if (!mg) {
6038             SWITCHSTACK(ary, oldstack);
6039             if (SvSMAGICAL(ary)) {
6040                 PUTBACK;
6041                 mg_set((SV*)ary);
6042                 SPAGAIN;
6043             }
6044             if (gimme == G_ARRAY) {
6045                 EXTEND(SP, iters);
6046                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6047                 SP += iters;
6048                 RETURN;
6049             }
6050         }
6051         else {
6052             PUTBACK;
6053             ENTER;
6054             call_method("PUSH",G_SCALAR|G_DISCARD);
6055             LEAVE;
6056             SPAGAIN;
6057             if (gimme == G_ARRAY) {
6058                 /* EXTEND should not be needed - we just popped them */
6059                 EXTEND(SP, iters);
6060                 for (i=0; i < iters; i++) {
6061                     SV **svp = av_fetch(ary, i, FALSE);
6062                     PUSHs((svp) ? *svp : &PL_sv_undef);
6063                 }
6064                 RETURN;
6065             }
6066         }
6067     }
6068     else {
6069         if (gimme == G_ARRAY)
6070             RETURN;
6071     }
6072     if (iters || !pm->op_pmreplroot) {
6073         GETTARGET;
6074         PUSHi(iters);
6075         RETURN;
6076     }
6077     RETPUSHUNDEF;
6078 }
6079
6080 #ifdef USE_THREADS
6081 void
6082 Perl_unlock_condpair(pTHX_ void *svv)
6083 {
6084     MAGIC *mg = mg_find((SV*)svv, 'm');
6085
6086     if (!mg)
6087         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6088     MUTEX_LOCK(MgMUTEXP(mg));
6089     if (MgOWNER(mg) != thr)
6090         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6091     MgOWNER(mg) = 0;
6092     COND_SIGNAL(MgOWNERCONDP(mg));
6093     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6094                           PTR2UV(thr), PTR2UV(svv));)
6095     MUTEX_UNLOCK(MgMUTEXP(mg));
6096 }
6097 #endif /* USE_THREADS */
6098
6099 PP(pp_lock)
6100 {
6101     djSP;
6102     dTOPss;
6103     SV *retsv = sv;
6104 #ifdef USE_THREADS
6105     sv_lock(sv);
6106 #endif /* USE_THREADS */
6107     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6108         || SvTYPE(retsv) == SVt_PVCV) {
6109         retsv = refto(retsv);
6110     }
6111     SETs(retsv);
6112     RETURN;
6113 }
6114
6115 PP(pp_threadsv)
6116 {
6117 #ifdef USE_THREADS
6118     djSP;
6119     EXTEND(SP, 1);
6120     if (PL_op->op_private & OPpLVAL_INTRO)
6121         PUSHs(*save_threadsv(PL_op->op_targ));
6122     else
6123         PUSHs(THREADSV(PL_op->op_targ));
6124     RETURN;
6125 #else
6126     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6127 #endif /* USE_THREADS */
6128 }