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         case 'U':
4333             if (len > strend - s)
4334                 len = strend - s;
4335             if (checksum) {
4336                 if (DO_UTF8(right)) {
4337                     while (len > 0) {
4338                         STRLEN l;
4339                         auv = utf8_to_uv((U8*)s, strend - s,
4340                                          &l, UTF8_ALLOW_ANYUV);
4341                         if (checksum > 32)
4342                             cdouble += (NV)auv;
4343                         else
4344                             culong += auv;
4345                         s += l;
4346                         len -= l;
4347                     }
4348                 }
4349                 else {
4350                 uchar_checksum:
4351                     while (len-- > 0) {
4352                         auint = *s++ & 0xFF;
4353                         culong += auint;
4354                     }
4355                 }
4356             }
4357             else {
4358                 EXTEND(SP, len);
4359                 EXTEND_MORTAL(len);
4360                 if (DO_UTF8(right)) {
4361                     while (len > 0) {
4362                         STRLEN l;
4363                         auv = utf8_to_uv((U8*)s, strend - s,
4364                                          &l, UTF8_ALLOW_ANYUV);
4365                         sv = NEWSV(37, 0);
4366                         sv_setuv(sv, auv);
4367                         PUSHs(sv_2mortal(sv));
4368                         s += l;
4369                         len -= l;
4370                     }
4371                 }
4372                 else {
4373                     while (len-- > 0) {
4374                         auint = *s++ & 0xFF;
4375                         sv = NEWSV(37, 0);
4376                         sv_setuv(sv, auint);
4377                         PUSHs(sv_2mortal(sv));
4378                     }
4379                 }
4380             }
4381             break;
4382         case 's':
4383 #if SHORTSIZE == SIZE16
4384             along = (strend - s) / SIZE16;
4385 #else
4386             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4387 #endif
4388             if (len > along)
4389                 len = along;
4390             if (checksum) {
4391 #if SHORTSIZE != SIZE16
4392                 if (natint) {
4393                     short ashort;
4394                     while (len-- > 0) {
4395                         COPYNN(s, &ashort, sizeof(short));
4396                         s += sizeof(short);
4397                         culong += ashort;
4398
4399                     }
4400                 }
4401                 else
4402 #endif
4403                 {
4404                     while (len-- > 0) {
4405                         COPY16(s, &ashort);
4406 #if SHORTSIZE > SIZE16
4407                         if (ashort > 32767)
4408                           ashort -= 65536;
4409 #endif
4410                         s += SIZE16;
4411                         culong += ashort;
4412                     }
4413                 }
4414             }
4415             else {
4416                 EXTEND(SP, len);
4417                 EXTEND_MORTAL(len);
4418 #if SHORTSIZE != SIZE16
4419                 if (natint) {
4420                     short ashort;
4421                     while (len-- > 0) {
4422                         COPYNN(s, &ashort, sizeof(short));
4423                         s += sizeof(short);
4424                         sv = NEWSV(38, 0);
4425                         sv_setiv(sv, (IV)ashort);
4426                         PUSHs(sv_2mortal(sv));
4427                     }
4428                 }
4429                 else
4430 #endif
4431                 {
4432                     while (len-- > 0) {
4433                         COPY16(s, &ashort);
4434 #if SHORTSIZE > SIZE16
4435                         if (ashort > 32767)
4436                           ashort -= 65536;
4437 #endif
4438                         s += SIZE16;
4439                         sv = NEWSV(38, 0);
4440                         sv_setiv(sv, (IV)ashort);
4441                         PUSHs(sv_2mortal(sv));
4442                     }
4443                 }
4444             }
4445             break;
4446         case 'v':
4447         case 'n':
4448         case 'S':
4449 #if SHORTSIZE == SIZE16
4450             along = (strend - s) / SIZE16;
4451 #else
4452             unatint = natint && datumtype == 'S';
4453             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4454 #endif
4455             if (len > along)
4456                 len = along;
4457             if (checksum) {
4458 #if SHORTSIZE != SIZE16
4459                 if (unatint) {
4460                     unsigned short aushort;
4461                     while (len-- > 0) {
4462                         COPYNN(s, &aushort, sizeof(unsigned short));
4463                         s += sizeof(unsigned short);
4464                         culong += aushort;
4465                     }
4466                 }
4467                 else
4468 #endif
4469                 {
4470                     while (len-- > 0) {
4471                         COPY16(s, &aushort);
4472                         s += SIZE16;
4473 #ifdef HAS_NTOHS
4474                         if (datumtype == 'n')
4475                             aushort = PerlSock_ntohs(aushort);
4476 #endif
4477 #ifdef HAS_VTOHS
4478                         if (datumtype == 'v')
4479                             aushort = vtohs(aushort);
4480 #endif
4481                         culong += aushort;
4482                     }
4483                 }
4484             }
4485             else {
4486                 EXTEND(SP, len);
4487                 EXTEND_MORTAL(len);
4488 #if SHORTSIZE != SIZE16
4489                 if (unatint) {
4490                     unsigned short aushort;
4491                     while (len-- > 0) {
4492                         COPYNN(s, &aushort, sizeof(unsigned short));
4493                         s += sizeof(unsigned short);
4494                         sv = NEWSV(39, 0);
4495                         sv_setiv(sv, (UV)aushort);
4496                         PUSHs(sv_2mortal(sv));
4497                     }
4498                 }
4499                 else
4500 #endif
4501                 {
4502                     while (len-- > 0) {
4503                         COPY16(s, &aushort);
4504                         s += SIZE16;
4505                         sv = NEWSV(39, 0);
4506 #ifdef HAS_NTOHS
4507                         if (datumtype == 'n')
4508                             aushort = PerlSock_ntohs(aushort);
4509 #endif
4510 #ifdef HAS_VTOHS
4511                         if (datumtype == 'v')
4512                             aushort = vtohs(aushort);
4513 #endif
4514                         sv_setiv(sv, (UV)aushort);
4515                         PUSHs(sv_2mortal(sv));
4516                     }
4517                 }
4518             }
4519             break;
4520         case 'i':
4521             along = (strend - s) / sizeof(int);
4522             if (len > along)
4523                 len = along;
4524             if (checksum) {
4525                 while (len-- > 0) {
4526                     Copy(s, &aint, 1, int);
4527                     s += sizeof(int);
4528                     if (checksum > 32)
4529                         cdouble += (NV)aint;
4530                     else
4531                         culong += aint;
4532                 }
4533             }
4534             else {
4535                 EXTEND(SP, len);
4536                 EXTEND_MORTAL(len);
4537                 while (len-- > 0) {
4538                     Copy(s, &aint, 1, int);
4539                     s += sizeof(int);
4540                     sv = NEWSV(40, 0);
4541 #ifdef __osf__
4542                     /* Without the dummy below unpack("i", pack("i",-1))
4543                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4544                      * cc with optimization turned on.
4545                      *
4546                      * The bug was detected in
4547                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4548                      * with optimization (-O4) turned on.
4549                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4550                      * does not have this problem even with -O4.
4551                      *
4552                      * This bug was reported as DECC_BUGS 1431
4553                      * and tracked internally as GEM_BUGS 7775.
4554                      *
4555                      * The bug is fixed in
4556                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
4557                      * UNIX V4.0F support:   DEC C V5.9-006 or later
4558                      * UNIX V4.0E support:   DEC C V5.8-011 or later
4559                      * and also in DTK.
4560                      *
4561                      * See also few lines later for the same bug.
4562                      */
4563                     (aint) ?
4564                         sv_setiv(sv, (IV)aint) :
4565 #endif
4566                     sv_setiv(sv, (IV)aint);
4567                     PUSHs(sv_2mortal(sv));
4568                 }
4569             }
4570             break;
4571         case 'I':
4572             along = (strend - s) / sizeof(unsigned int);
4573             if (len > along)
4574                 len = along;
4575             if (checksum) {
4576                 while (len-- > 0) {
4577                     Copy(s, &auint, 1, unsigned int);
4578                     s += sizeof(unsigned int);
4579                     if (checksum > 32)
4580                         cdouble += (NV)auint;
4581                     else
4582                         culong += auint;
4583                 }
4584             }
4585             else {
4586                 EXTEND(SP, len);
4587                 EXTEND_MORTAL(len);
4588                 while (len-- > 0) {
4589                     Copy(s, &auint, 1, unsigned int);
4590                     s += sizeof(unsigned int);
4591                     sv = NEWSV(41, 0);
4592 #ifdef __osf__
4593                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4594                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4595                      * See details few lines earlier. */
4596                     (auint) ?
4597                         sv_setuv(sv, (UV)auint) :
4598 #endif
4599                     sv_setuv(sv, (UV)auint);
4600                     PUSHs(sv_2mortal(sv));
4601                 }
4602             }
4603             break;
4604         case 'l':
4605 #if LONGSIZE == SIZE32
4606             along = (strend - s) / SIZE32;
4607 #else
4608             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4609 #endif
4610             if (len > along)
4611                 len = along;
4612             if (checksum) {
4613 #if LONGSIZE != SIZE32
4614                 if (natint) {
4615                     while (len-- > 0) {
4616                         COPYNN(s, &along, sizeof(long));
4617                         s += sizeof(long);
4618                         if (checksum > 32)
4619                             cdouble += (NV)along;
4620                         else
4621                             culong += along;
4622                     }
4623                 }
4624                 else
4625 #endif
4626                 {
4627                     while (len-- > 0) {
4628 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4629                         I32 along;
4630 #endif
4631                         COPY32(s, &along);
4632 #if LONGSIZE > SIZE32
4633                         if (along > 2147483647)
4634                           along -= 4294967296;
4635 #endif
4636                         s += SIZE32;
4637                         if (checksum > 32)
4638                             cdouble += (NV)along;
4639                         else
4640                             culong += along;
4641                     }
4642                 }
4643             }
4644             else {
4645                 EXTEND(SP, len);
4646                 EXTEND_MORTAL(len);
4647 #if LONGSIZE != SIZE32
4648                 if (natint) {
4649                     while (len-- > 0) {
4650                         COPYNN(s, &along, sizeof(long));
4651                         s += sizeof(long);
4652                         sv = NEWSV(42, 0);
4653                         sv_setiv(sv, (IV)along);
4654                         PUSHs(sv_2mortal(sv));
4655                     }
4656                 }
4657                 else
4658 #endif
4659                 {
4660                     while (len-- > 0) {
4661 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4662                         I32 along;
4663 #endif
4664                         COPY32(s, &along);
4665 #if LONGSIZE > SIZE32
4666                         if (along > 2147483647)
4667                           along -= 4294967296;
4668 #endif
4669                         s += SIZE32;
4670                         sv = NEWSV(42, 0);
4671                         sv_setiv(sv, (IV)along);
4672                         PUSHs(sv_2mortal(sv));
4673                     }
4674                 }
4675             }
4676             break;
4677         case 'V':
4678         case 'N':
4679         case 'L':
4680 #if LONGSIZE == SIZE32
4681             along = (strend - s) / SIZE32;
4682 #else
4683             unatint = natint && datumtype == 'L';
4684             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4685 #endif
4686             if (len > along)
4687                 len = along;
4688             if (checksum) {
4689 #if LONGSIZE != SIZE32
4690                 if (unatint) {
4691                     unsigned long aulong;
4692                     while (len-- > 0) {
4693                         COPYNN(s, &aulong, sizeof(unsigned long));
4694                         s += sizeof(unsigned long);
4695                         if (checksum > 32)
4696                             cdouble += (NV)aulong;
4697                         else
4698                             culong += aulong;
4699                     }
4700                 }
4701                 else
4702 #endif
4703                 {
4704                     while (len-- > 0) {
4705                         COPY32(s, &aulong);
4706                         s += SIZE32;
4707 #ifdef HAS_NTOHL
4708                         if (datumtype == 'N')
4709                             aulong = PerlSock_ntohl(aulong);
4710 #endif
4711 #ifdef HAS_VTOHL
4712                         if (datumtype == 'V')
4713                             aulong = vtohl(aulong);
4714 #endif
4715                         if (checksum > 32)
4716                             cdouble += (NV)aulong;
4717                         else
4718                             culong += aulong;
4719                     }
4720                 }
4721             }
4722             else {
4723                 EXTEND(SP, len);
4724                 EXTEND_MORTAL(len);
4725 #if LONGSIZE != SIZE32
4726                 if (unatint) {
4727                     unsigned long aulong;
4728                     while (len-- > 0) {
4729                         COPYNN(s, &aulong, sizeof(unsigned long));
4730                         s += sizeof(unsigned long);
4731                         sv = NEWSV(43, 0);
4732                         sv_setuv(sv, (UV)aulong);
4733                         PUSHs(sv_2mortal(sv));
4734                     }
4735                 }
4736                 else
4737 #endif
4738                 {
4739                     while (len-- > 0) {
4740                         COPY32(s, &aulong);
4741                         s += SIZE32;
4742 #ifdef HAS_NTOHL
4743                         if (datumtype == 'N')
4744                             aulong = PerlSock_ntohl(aulong);
4745 #endif
4746 #ifdef HAS_VTOHL
4747                         if (datumtype == 'V')
4748                             aulong = vtohl(aulong);
4749 #endif
4750                         sv = NEWSV(43, 0);
4751                         sv_setuv(sv, (UV)aulong);
4752                         PUSHs(sv_2mortal(sv));
4753                     }
4754                 }
4755             }
4756             break;
4757         case 'p':
4758             along = (strend - s) / sizeof(char*);
4759             if (len > along)
4760                 len = along;
4761             EXTEND(SP, len);
4762             EXTEND_MORTAL(len);
4763             while (len-- > 0) {
4764                 if (sizeof(char*) > strend - s)
4765                     break;
4766                 else {
4767                     Copy(s, &aptr, 1, char*);
4768                     s += sizeof(char*);
4769                 }
4770                 sv = NEWSV(44, 0);
4771                 if (aptr)
4772                     sv_setpv(sv, aptr);
4773                 PUSHs(sv_2mortal(sv));
4774             }
4775             break;
4776         case 'w':
4777             EXTEND(SP, len);
4778             EXTEND_MORTAL(len);
4779             {
4780                 UV auv = 0;
4781                 U32 bytes = 0;
4782
4783                 while ((len > 0) && (s < strend)) {
4784                     auv = (auv << 7) | (*s & 0x7f);
4785                     if (UTF8_IS_ASCII(*s++)) {
4786                         bytes = 0;
4787                         sv = NEWSV(40, 0);
4788                         sv_setuv(sv, auv);
4789                         PUSHs(sv_2mortal(sv));
4790                         len--;
4791                         auv = 0;
4792                     }
4793                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4794                         char *t;
4795                         STRLEN n_a;
4796
4797                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4798                         while (s < strend) {
4799                             sv = mul128(sv, *s & 0x7f);
4800                             if (!(*s++ & 0x80)) {
4801                                 bytes = 0;
4802                                 break;
4803                             }
4804                         }
4805                         t = SvPV(sv, n_a);
4806                         while (*t == '0')
4807                             t++;
4808                         sv_chop(sv, t);
4809                         PUSHs(sv_2mortal(sv));
4810                         len--;
4811                         auv = 0;
4812                     }
4813                 }
4814                 if ((s >= strend) && bytes)
4815                     DIE(aTHX_ "Unterminated compressed integer");
4816             }
4817             break;
4818         case 'P':
4819             EXTEND(SP, 1);
4820             if (sizeof(char*) > strend - s)
4821                 break;
4822             else {
4823                 Copy(s, &aptr, 1, char*);
4824                 s += sizeof(char*);
4825             }
4826             sv = NEWSV(44, 0);
4827             if (aptr)
4828                 sv_setpvn(sv, aptr, len);
4829             PUSHs(sv_2mortal(sv));
4830             break;
4831 #ifdef HAS_QUAD
4832         case 'q':
4833             along = (strend - s) / sizeof(Quad_t);
4834             if (len > along)
4835                 len = along;
4836             EXTEND(SP, len);
4837             EXTEND_MORTAL(len);
4838             while (len-- > 0) {
4839                 if (s + sizeof(Quad_t) > strend)
4840                     aquad = 0;
4841                 else {
4842                     Copy(s, &aquad, 1, Quad_t);
4843                     s += sizeof(Quad_t);
4844                 }
4845                 sv = NEWSV(42, 0);
4846                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4847                     sv_setiv(sv, (IV)aquad);
4848                 else
4849                     sv_setnv(sv, (NV)aquad);
4850                 PUSHs(sv_2mortal(sv));
4851             }
4852             break;
4853         case 'Q':
4854             along = (strend - s) / sizeof(Quad_t);
4855             if (len > along)
4856                 len = along;
4857             EXTEND(SP, len);
4858             EXTEND_MORTAL(len);
4859             while (len-- > 0) {
4860                 if (s + sizeof(Uquad_t) > strend)
4861                     auquad = 0;
4862                 else {
4863                     Copy(s, &auquad, 1, Uquad_t);
4864                     s += sizeof(Uquad_t);
4865                 }
4866                 sv = NEWSV(43, 0);
4867                 if (auquad <= UV_MAX)
4868                     sv_setuv(sv, (UV)auquad);
4869                 else
4870                     sv_setnv(sv, (NV)auquad);
4871                 PUSHs(sv_2mortal(sv));
4872             }
4873             break;
4874 #endif
4875         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4876         case 'f':
4877         case 'F':
4878             along = (strend - s) / sizeof(float);
4879             if (len > along)
4880                 len = along;
4881             if (checksum) {
4882                 while (len-- > 0) {
4883                     Copy(s, &afloat, 1, float);
4884                     s += sizeof(float);
4885                     cdouble += afloat;
4886                 }
4887             }
4888             else {
4889                 EXTEND(SP, len);
4890                 EXTEND_MORTAL(len);
4891                 while (len-- > 0) {
4892                     Copy(s, &afloat, 1, float);
4893                     s += sizeof(float);
4894                     sv = NEWSV(47, 0);
4895                     sv_setnv(sv, (NV)afloat);
4896                     PUSHs(sv_2mortal(sv));
4897                 }
4898             }
4899             break;
4900         case 'd':
4901         case 'D':
4902             along = (strend - s) / sizeof(double);
4903             if (len > along)
4904                 len = along;
4905             if (checksum) {
4906                 while (len-- > 0) {
4907                     Copy(s, &adouble, 1, double);
4908                     s += sizeof(double);
4909                     cdouble += adouble;
4910                 }
4911             }
4912             else {
4913                 EXTEND(SP, len);
4914                 EXTEND_MORTAL(len);
4915                 while (len-- > 0) {
4916                     Copy(s, &adouble, 1, double);
4917                     s += sizeof(double);
4918                     sv = NEWSV(48, 0);
4919                     sv_setnv(sv, (NV)adouble);
4920                     PUSHs(sv_2mortal(sv));
4921                 }
4922             }
4923             break;
4924         case 'u':
4925             /* MKS:
4926              * Initialise the decode mapping.  By using a table driven
4927              * algorithm, the code will be character-set independent
4928              * (and just as fast as doing character arithmetic)
4929              */
4930             if (PL_uudmap['M'] == 0) {
4931                 int i;
4932
4933                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4934                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4935                 /*
4936                  * Because ' ' and '`' map to the same value,
4937                  * we need to decode them both the same.
4938                  */
4939                 PL_uudmap[' '] = 0;
4940             }
4941
4942             along = (strend - s) * 3 / 4;
4943             sv = NEWSV(42, along);
4944             if (along)
4945                 SvPOK_on(sv);
4946             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4947                 I32 a, b, c, d;
4948                 char hunk[4];
4949
4950                 hunk[3] = '\0';
4951                 len = PL_uudmap[*(U8*)s++] & 077;
4952                 while (len > 0) {
4953                     if (s < strend && ISUUCHAR(*s))
4954                         a = PL_uudmap[*(U8*)s++] & 077;
4955                     else
4956                         a = 0;
4957                     if (s < strend && ISUUCHAR(*s))
4958                         b = PL_uudmap[*(U8*)s++] & 077;
4959                     else
4960                         b = 0;
4961                     if (s < strend && ISUUCHAR(*s))
4962                         c = PL_uudmap[*(U8*)s++] & 077;
4963                     else
4964                         c = 0;
4965                     if (s < strend && ISUUCHAR(*s))
4966                         d = PL_uudmap[*(U8*)s++] & 077;
4967                     else
4968                         d = 0;
4969                     hunk[0] = (a << 2) | (b >> 4);
4970                     hunk[1] = (b << 4) | (c >> 2);
4971                     hunk[2] = (c << 6) | d;
4972                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4973                     len -= 3;
4974                 }
4975                 if (*s == '\n')
4976                     s++;
4977                 else if (s[1] == '\n')          /* possible checksum byte */
4978                     s += 2;
4979             }
4980             XPUSHs(sv_2mortal(sv));
4981             break;
4982         }
4983         if (checksum) {
4984             sv = NEWSV(42, 0);
4985             if (strchr("fFdD", datumtype) ||
4986               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4987                 NV trouble;
4988
4989                 adouble = 1.0;
4990                 while (checksum >= 16) {
4991                     checksum -= 16;
4992                     adouble *= 65536.0;
4993                 }
4994                 while (checksum >= 4) {
4995                     checksum -= 4;
4996                     adouble *= 16.0;
4997                 }
4998                 while (checksum--)
4999                     adouble *= 2.0;
5000                 along = (1 << checksum) - 1;
5001                 while (cdouble < 0.0)
5002                     cdouble += adouble;
5003                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5004                 sv_setnv(sv, cdouble);
5005             }
5006             else {
5007                 if (checksum < 32) {
5008                     aulong = (1 << checksum) - 1;
5009                     culong &= aulong;
5010                 }
5011                 sv_setuv(sv, (UV)culong);
5012             }
5013             XPUSHs(sv_2mortal(sv));
5014             checksum = 0;
5015         }
5016     }
5017     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5018         PUSHs(&PL_sv_undef);
5019     RETURN;
5020 }
5021
5022 STATIC void
5023 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5024 {
5025     char hunk[5];
5026
5027     *hunk = PL_uuemap[len];
5028     sv_catpvn(sv, hunk, 1);
5029     hunk[4] = '\0';
5030     while (len > 2) {
5031         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5032         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5033         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5034         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5035         sv_catpvn(sv, hunk, 4);
5036         s += 3;
5037         len -= 3;
5038     }
5039     if (len > 0) {
5040         char r = (len > 1 ? s[1] : '\0');
5041         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5042         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5043         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5044         hunk[3] = PL_uuemap[0];
5045         sv_catpvn(sv, hunk, 4);
5046     }
5047     sv_catpvn(sv, "\n", 1);
5048 }
5049
5050 STATIC SV *
5051 S_is_an_int(pTHX_ char *s, STRLEN l)
5052 {
5053   STRLEN         n_a;
5054   SV             *result = newSVpvn(s, l);
5055   char           *result_c = SvPV(result, n_a); /* convenience */
5056   char           *out = result_c;
5057   bool            skip = 1;
5058   bool            ignore = 0;
5059
5060   while (*s) {
5061     switch (*s) {
5062     case ' ':
5063       break;
5064     case '+':
5065       if (!skip) {
5066         SvREFCNT_dec(result);
5067         return (NULL);
5068       }
5069       break;
5070     case '0':
5071     case '1':
5072     case '2':
5073     case '3':
5074     case '4':
5075     case '5':
5076     case '6':
5077     case '7':
5078     case '8':
5079     case '9':
5080       skip = 0;
5081       if (!ignore) {
5082         *(out++) = *s;
5083       }
5084       break;
5085     case '.':
5086       ignore = 1;
5087       break;
5088     default:
5089       SvREFCNT_dec(result);
5090       return (NULL);
5091     }
5092     s++;
5093   }
5094   *(out++) = '\0';
5095   SvCUR_set(result, out - result_c);
5096   return (result);
5097 }
5098
5099 /* pnum must be '\0' terminated */
5100 STATIC int
5101 S_div128(pTHX_ SV *pnum, bool *done)
5102 {
5103   STRLEN          len;
5104   char           *s = SvPV(pnum, len);
5105   int             m = 0;
5106   int             r = 0;
5107   char           *t = s;
5108
5109   *done = 1;
5110   while (*t) {
5111     int             i;
5112
5113     i = m * 10 + (*t - '0');
5114     m = i & 0x7F;
5115     r = (i >> 7);               /* r < 10 */
5116     if (r) {
5117       *done = 0;
5118     }
5119     *(t++) = '0' + r;
5120   }
5121   *(t++) = '\0';
5122   SvCUR_set(pnum, (STRLEN) (t - s));
5123   return (m);
5124 }
5125
5126
5127 PP(pp_pack)
5128 {
5129     djSP; dMARK; dORIGMARK; dTARGET;
5130     register SV *cat = TARG;
5131     register I32 items;
5132     STRLEN fromlen;
5133     register char *pat = SvPVx(*++MARK, fromlen);
5134     char *patcopy;
5135     register char *patend = pat + fromlen;
5136     register I32 len;
5137     I32 datumtype;
5138     SV *fromstr;
5139     /*SUPPRESS 442*/
5140     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5141     static char *space10 = "          ";
5142
5143     /* These must not be in registers: */
5144     char achar;
5145     I16 ashort;
5146     int aint;
5147     unsigned int auint;
5148     I32 along;
5149     U32 aulong;
5150     UV auv;
5151 #ifdef HAS_QUAD
5152     Quad_t aquad;
5153     Uquad_t auquad;
5154 #endif
5155     char *aptr;
5156     float afloat;
5157     double adouble;
5158     int commas = 0;
5159 #ifdef PERL_NATINT_PACK
5160     int natint;         /* native integer */
5161 #endif
5162     bool has_utf8;
5163
5164     items = SP - MARK;
5165     MARK++;
5166     sv_setpvn(cat, "", 0);
5167     patcopy = pat;
5168     while (pat < patend) {
5169         SV *lengthcode = Nullsv;
5170 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5171         datumtype = *pat++ & 0xFF;
5172 #ifdef PERL_NATINT_PACK
5173         natint = 0;
5174 #endif
5175         if (isSPACE(datumtype)) {
5176             patcopy++;
5177             continue;
5178         }
5179         if (datumtype == 'U' && pat == patcopy+1)
5180             SvUTF8_on(cat);
5181         if (datumtype == '#') {
5182             while (pat < patend && *pat != '\n')
5183                 pat++;
5184             continue;
5185         }
5186         if (*pat == '!') {
5187             char *natstr = "sSiIlL";
5188
5189             if (strchr(natstr, datumtype)) {
5190 #ifdef PERL_NATINT_PACK
5191                 natint = 1;
5192 #endif
5193                 pat++;
5194             }
5195             else
5196                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5197         }
5198         if (*pat == '*') {
5199             len = strchr("@Xxu", datumtype) ? 0 : items;
5200             pat++;
5201         }
5202         else if (isDIGIT(*pat)) {
5203             len = *pat++ - '0';
5204             while (isDIGIT(*pat)) {
5205                 len = (len * 10) + (*pat++ - '0');
5206                 if (len < 0)
5207                     DIE(aTHX_ "Repeat count in pack overflows");
5208             }
5209         }
5210         else
5211             len = 1;
5212         if (*pat == '/') {
5213             ++pat;
5214             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5215                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5216             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5217                                                    ? *MARK : &PL_sv_no)
5218                                             + (*pat == 'Z' ? 1 : 0)));
5219         }
5220         switch(datumtype) {
5221         default:
5222             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5223         case ',': /* grandfather in commas but with a warning */
5224             if (commas++ == 0 && ckWARN(WARN_PACK))
5225                 Perl_warner(aTHX_ WARN_PACK,
5226                             "Invalid type in pack: '%c'", (int)datumtype);
5227             break;
5228         case '%':
5229             DIE(aTHX_ "%% may only be used in unpack");
5230         case '@':
5231             len -= SvCUR(cat);
5232             if (len > 0)
5233                 goto grow;
5234             len = -len;
5235             if (len > 0)
5236                 goto shrink;
5237             break;
5238         case 'X':
5239           shrink:
5240             if (SvCUR(cat) < len)
5241                 DIE(aTHX_ "X outside of string");
5242             SvCUR(cat) -= len;
5243             *SvEND(cat) = '\0';
5244             break;
5245         case 'x':
5246           grow:
5247             while (len >= 10) {
5248                 sv_catpvn(cat, null10, 10);
5249                 len -= 10;
5250             }
5251             sv_catpvn(cat, null10, len);
5252             break;
5253         case 'A':
5254         case 'Z':
5255         case 'a':
5256             fromstr = NEXTFROM;
5257             aptr = SvPV(fromstr, fromlen);
5258             if (pat[-1] == '*') {
5259                 len = fromlen;
5260                 if (datumtype == 'Z')
5261                     ++len;
5262             }
5263             if (fromlen >= len) {
5264                 sv_catpvn(cat, aptr, len);
5265                 if (datumtype == 'Z')
5266                     *(SvEND(cat)-1) = '\0';
5267             }
5268             else {
5269                 sv_catpvn(cat, aptr, fromlen);
5270                 len -= fromlen;
5271                 if (datumtype == 'A') {
5272                     while (len >= 10) {
5273                         sv_catpvn(cat, space10, 10);
5274                         len -= 10;
5275                     }
5276                     sv_catpvn(cat, space10, len);
5277                 }
5278                 else {
5279                     while (len >= 10) {
5280                         sv_catpvn(cat, null10, 10);
5281                         len -= 10;
5282                     }
5283                     sv_catpvn(cat, null10, len);
5284                 }
5285             }
5286             break;
5287         case 'B':
5288         case 'b':
5289             {
5290                 register char *str;
5291                 I32 saveitems;
5292
5293                 fromstr = NEXTFROM;
5294                 saveitems = items;
5295                 str = SvPV(fromstr, fromlen);
5296                 if (pat[-1] == '*')
5297                     len = fromlen;
5298                 aint = SvCUR(cat);
5299                 SvCUR(cat) += (len+7)/8;
5300                 SvGROW(cat, SvCUR(cat) + 1);
5301                 aptr = SvPVX(cat) + aint;
5302                 if (len > fromlen)
5303                     len = fromlen;
5304                 aint = len;
5305                 items = 0;
5306                 if (datumtype == 'B') {
5307                     for (len = 0; len++ < aint;) {
5308                         items |= *str++ & 1;
5309                         if (len & 7)
5310                             items <<= 1;
5311                         else {
5312                             *aptr++ = items & 0xff;
5313                             items = 0;
5314                         }
5315                     }
5316                 }
5317                 else {
5318                     for (len = 0; len++ < aint;) {
5319                         if (*str++ & 1)
5320                             items |= 128;
5321                         if (len & 7)
5322                             items >>= 1;
5323                         else {
5324                             *aptr++ = items & 0xff;
5325                             items = 0;
5326                         }
5327                     }
5328                 }
5329                 if (aint & 7) {
5330                     if (datumtype == 'B')
5331                         items <<= 7 - (aint & 7);
5332                     else
5333                         items >>= 7 - (aint & 7);
5334                     *aptr++ = items & 0xff;
5335                 }
5336                 str = SvPVX(cat) + SvCUR(cat);
5337                 while (aptr <= str)
5338                     *aptr++ = '\0';
5339
5340                 items = saveitems;
5341             }
5342             break;
5343         case 'H':
5344         case 'h':
5345             {
5346                 register char *str;
5347                 I32 saveitems;
5348
5349                 fromstr = NEXTFROM;
5350                 saveitems = items;
5351                 str = SvPV(fromstr, fromlen);
5352                 if (pat[-1] == '*')
5353                     len = fromlen;
5354                 aint = SvCUR(cat);
5355                 SvCUR(cat) += (len+1)/2;
5356                 SvGROW(cat, SvCUR(cat) + 1);
5357                 aptr = SvPVX(cat) + aint;
5358                 if (len > fromlen)
5359                     len = fromlen;
5360                 aint = len;
5361                 items = 0;
5362                 if (datumtype == 'H') {
5363                     for (len = 0; len++ < aint;) {
5364                         if (isALPHA(*str))
5365                             items |= ((*str++ & 15) + 9) & 15;
5366                         else
5367                             items |= *str++ & 15;
5368                         if (len & 1)
5369                             items <<= 4;
5370                         else {
5371                             *aptr++ = items & 0xff;
5372                             items = 0;
5373                         }
5374                     }
5375                 }
5376                 else {
5377                     for (len = 0; len++ < aint;) {
5378                         if (isALPHA(*str))
5379                             items |= (((*str++ & 15) + 9) & 15) << 4;
5380                         else
5381                             items |= (*str++ & 15) << 4;
5382                         if (len & 1)
5383                             items >>= 4;
5384                         else {
5385                             *aptr++ = items & 0xff;
5386                             items = 0;
5387                         }
5388                     }
5389                 }
5390                 if (aint & 1)
5391                     *aptr++ = items & 0xff;
5392                 str = SvPVX(cat) + SvCUR(cat);
5393                 while (aptr <= str)
5394                     *aptr++ = '\0';
5395
5396                 items = saveitems;
5397             }
5398             break;
5399         case 'c':
5400             while (len-- > 0) {
5401                 fromstr = NEXTFROM;
5402                 aint = SvIV(fromstr);
5403                 achar = aint;
5404                 sv_catpvn(cat, &achar, sizeof(char));
5405             }
5406             break;
5407         case 'C':
5408             has_utf8 = SvUTF8(cat);
5409             while (len-- > 0) {
5410                 fromstr = NEXTFROM;
5411                 auv = SvUV(fromstr);
5412                 if (!has_utf8 && auv > 0xFF && !IN_BYTE) {
5413                     has_utf8 = TRUE;
5414                     if (SvCUR(cat))
5415                         sv_utf8_upgrade(cat);
5416                     else
5417                         SvUTF8_on(cat); /* There will be UTF8. */
5418                 }
5419                 if (has_utf8) {
5420                     SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5421                     SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5422                                    - SvPVX(cat));
5423                 }
5424                 else {
5425                     achar = auv;
5426                     sv_catpvn(cat, &achar, sizeof(char));
5427                 }
5428             }
5429             *SvEND(cat) = '\0';
5430             break;
5431         case 'U':
5432             has_utf8 = SvUTF8(cat);
5433             while (len-- > 0) {
5434                 fromstr = NEXTFROM;
5435                 auv = SvUV(fromstr);
5436                 if (!has_utf8 && auv > 0x80) {
5437                     has_utf8 = TRUE;
5438                     sv_utf8_upgrade(cat);
5439                 }
5440                 SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5441                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5442                                - SvPVX(cat));
5443             }
5444             *SvEND(cat) = '\0';
5445             break;
5446         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5447         case 'f':
5448         case 'F':
5449             while (len-- > 0) {
5450                 fromstr = NEXTFROM;
5451                 afloat = (float)SvNV(fromstr);
5452                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5453             }
5454             break;
5455         case 'd':
5456         case 'D':
5457             while (len-- > 0) {
5458                 fromstr = NEXTFROM;
5459                 adouble = (double)SvNV(fromstr);
5460                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5461             }
5462             break;
5463         case 'n':
5464             while (len-- > 0) {
5465                 fromstr = NEXTFROM;
5466                 ashort = (I16)SvIV(fromstr);
5467 #ifdef HAS_HTONS
5468                 ashort = PerlSock_htons(ashort);
5469 #endif
5470                 CAT16(cat, &ashort);
5471             }
5472             break;
5473         case 'v':
5474             while (len-- > 0) {
5475                 fromstr = NEXTFROM;
5476                 ashort = (I16)SvIV(fromstr);
5477 #ifdef HAS_HTOVS
5478                 ashort = htovs(ashort);
5479 #endif
5480                 CAT16(cat, &ashort);
5481             }
5482             break;
5483         case 'S':
5484 #if SHORTSIZE != SIZE16
5485             if (natint) {
5486                 unsigned short aushort;
5487
5488                 while (len-- > 0) {
5489                     fromstr = NEXTFROM;
5490                     aushort = SvUV(fromstr);
5491                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5492                 }
5493             }
5494             else
5495 #endif
5496             {
5497                 U16 aushort;
5498
5499                 while (len-- > 0) {
5500                     fromstr = NEXTFROM;
5501                     aushort = (U16)SvUV(fromstr);
5502                     CAT16(cat, &aushort);
5503                 }
5504
5505             }
5506             break;
5507         case 's':
5508 #if SHORTSIZE != SIZE16
5509             if (natint) {
5510                 short ashort;
5511
5512                 while (len-- > 0) {
5513                     fromstr = NEXTFROM;
5514                     ashort = SvIV(fromstr);
5515                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5516                 }
5517             }
5518             else
5519 #endif
5520             {
5521                 while (len-- > 0) {
5522                     fromstr = NEXTFROM;
5523                     ashort = (I16)SvIV(fromstr);
5524                     CAT16(cat, &ashort);
5525                 }
5526             }
5527             break;
5528         case 'I':
5529             while (len-- > 0) {
5530                 fromstr = NEXTFROM;
5531                 auint = SvUV(fromstr);
5532                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5533             }
5534             break;
5535         case 'w':
5536             while (len-- > 0) {
5537                 fromstr = NEXTFROM;
5538                 adouble = Perl_floor(SvNV(fromstr));
5539
5540                 if (adouble < 0)
5541                     DIE(aTHX_ "Cannot compress negative numbers");
5542
5543                 if (
5544 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5545                     adouble <= 0xffffffff
5546 #else
5547 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5548                     adouble <= UV_MAX_cxux
5549 #   else
5550                     adouble <= UV_MAX
5551 #   endif
5552 #endif
5553                     )
5554                 {
5555                     char   buf[1 + sizeof(UV)];
5556                     char  *in = buf + sizeof(buf);
5557                     UV     auv = U_V(adouble);
5558
5559                     do {
5560                         *--in = (auv & 0x7f) | 0x80;
5561                         auv >>= 7;
5562                     } while (auv);
5563                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5564                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5565                 }
5566                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5567                     char           *from, *result, *in;
5568                     SV             *norm;
5569                     STRLEN          len;
5570                     bool            done;
5571
5572                     /* Copy string and check for compliance */
5573                     from = SvPV(fromstr, len);
5574                     if ((norm = is_an_int(from, len)) == NULL)
5575                         DIE(aTHX_ "can compress only unsigned integer");
5576
5577                     New('w', result, len, char);
5578                     in = result + len;
5579                     done = FALSE;
5580                     while (!done)
5581                         *--in = div128(norm, &done) | 0x80;
5582                     result[len - 1] &= 0x7F; /* clear continue bit */
5583                     sv_catpvn(cat, in, (result + len) - in);
5584                     Safefree(result);
5585                     SvREFCNT_dec(norm); /* free norm */
5586                 }
5587                 else if (SvNOKp(fromstr)) {
5588                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5589                     char  *in = buf + sizeof(buf);
5590
5591                     do {
5592                         double next = floor(adouble / 128);
5593                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5594                         if (in <= buf)  /* this cannot happen ;-) */
5595                             DIE(aTHX_ "Cannot compress integer");
5596                         in--;
5597                         adouble = next;
5598                     } while (adouble > 0);
5599                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5600                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5601                 }
5602                 else
5603                     DIE(aTHX_ "Cannot compress non integer");
5604             }
5605             break;
5606         case 'i':
5607             while (len-- > 0) {
5608                 fromstr = NEXTFROM;
5609                 aint = SvIV(fromstr);
5610                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5611             }
5612             break;
5613         case 'N':
5614             while (len-- > 0) {
5615                 fromstr = NEXTFROM;
5616                 aulong = SvUV(fromstr);
5617 #ifdef HAS_HTONL
5618                 aulong = PerlSock_htonl(aulong);
5619 #endif
5620                 CAT32(cat, &aulong);
5621             }
5622             break;
5623         case 'V':
5624             while (len-- > 0) {
5625                 fromstr = NEXTFROM;
5626                 aulong = SvUV(fromstr);
5627 #ifdef HAS_HTOVL
5628                 aulong = htovl(aulong);
5629 #endif
5630                 CAT32(cat, &aulong);
5631             }
5632             break;
5633         case 'L':
5634 #if LONGSIZE != SIZE32
5635             if (natint) {
5636                 unsigned long aulong;
5637
5638                 while (len-- > 0) {
5639                     fromstr = NEXTFROM;
5640                     aulong = SvUV(fromstr);
5641                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5642                 }
5643             }
5644             else
5645 #endif
5646             {
5647                 while (len-- > 0) {
5648                     fromstr = NEXTFROM;
5649                     aulong = SvUV(fromstr);
5650                     CAT32(cat, &aulong);
5651                 }
5652             }
5653             break;
5654         case 'l':
5655 #if LONGSIZE != SIZE32
5656             if (natint) {
5657                 long along;
5658
5659                 while (len-- > 0) {
5660                     fromstr = NEXTFROM;
5661                     along = SvIV(fromstr);
5662                     sv_catpvn(cat, (char *)&along, sizeof(long));
5663                 }
5664             }
5665             else
5666 #endif
5667             {
5668                 while (len-- > 0) {
5669                     fromstr = NEXTFROM;
5670                     along = SvIV(fromstr);
5671                     CAT32(cat, &along);
5672                 }
5673             }
5674             break;
5675 #ifdef HAS_QUAD
5676         case 'Q':
5677             while (len-- > 0) {
5678                 fromstr = NEXTFROM;
5679                 auquad = (Uquad_t)SvUV(fromstr);
5680                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5681             }
5682             break;
5683         case 'q':
5684             while (len-- > 0) {
5685                 fromstr = NEXTFROM;
5686                 aquad = (Quad_t)SvIV(fromstr);
5687                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5688             }
5689             break;
5690 #endif
5691         case 'P':
5692             len = 1;            /* assume SV is correct length */
5693             /* FALL THROUGH */
5694         case 'p':
5695             while (len-- > 0) {
5696                 fromstr = NEXTFROM;
5697                 if (fromstr == &PL_sv_undef)
5698                     aptr = NULL;
5699                 else {
5700                     STRLEN n_a;
5701                     /* XXX better yet, could spirit away the string to
5702                      * a safe spot and hang on to it until the result
5703                      * of pack() (and all copies of the result) are
5704                      * gone.
5705                      */
5706                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5707                                                 || (SvPADTMP(fromstr)
5708                                                     && !SvREADONLY(fromstr))))
5709                     {
5710                         Perl_warner(aTHX_ WARN_PACK,
5711                                 "Attempt to pack pointer to temporary value");
5712                     }
5713                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5714                         aptr = SvPV(fromstr,n_a);
5715                     else
5716                         aptr = SvPV_force(fromstr,n_a);
5717                 }
5718                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5719             }
5720             break;
5721         case 'u':
5722             fromstr = NEXTFROM;
5723             aptr = SvPV(fromstr, fromlen);
5724             SvGROW(cat, fromlen * 4 / 3);
5725             if (len <= 1)
5726                 len = 45;
5727             else
5728                 len = len / 3 * 3;
5729             while (fromlen > 0) {
5730                 I32 todo;
5731
5732                 if (fromlen > len)
5733                     todo = len;
5734                 else
5735                     todo = fromlen;
5736                 doencodes(cat, aptr, todo);
5737                 fromlen -= todo;
5738                 aptr += todo;
5739             }
5740             break;
5741         }
5742     }
5743     SvSETMAGIC(cat);
5744     SP = ORIGMARK;
5745     PUSHs(cat);
5746     RETURN;
5747 }
5748 #undef NEXTFROM
5749
5750
5751 PP(pp_split)
5752 {
5753     djSP; dTARG;
5754     AV *ary;
5755     register IV limit = POPi;                   /* note, negative is forever */
5756     SV *sv = POPs;
5757     STRLEN len;
5758     register char *s = SvPV(sv, len);
5759     bool do_utf8 = DO_UTF8(sv);
5760     char *strend = s + len;
5761     register PMOP *pm;
5762     register REGEXP *rx;
5763     register SV *dstr;
5764     register char *m;
5765     I32 iters = 0;
5766     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5767     I32 maxiters = slen + 10;
5768     I32 i;
5769     char *orig;
5770     I32 origlimit = limit;
5771     I32 realarray = 0;
5772     I32 base;
5773     AV *oldstack = PL_curstack;
5774     I32 gimme = GIMME_V;
5775     I32 oldsave = PL_savestack_ix;
5776     I32 make_mortal = 1;
5777     MAGIC *mg = (MAGIC *) NULL;
5778
5779 #ifdef DEBUGGING
5780     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5781 #else
5782     pm = (PMOP*)POPs;
5783 #endif
5784     if (!pm || !s)
5785         DIE(aTHX_ "panic: pp_split");
5786     rx = pm->op_pmregexp;
5787
5788     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5789              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5790
5791     if (pm->op_pmreplroot) {
5792 #ifdef USE_ITHREADS
5793         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5794 #else
5795         ary = GvAVn((GV*)pm->op_pmreplroot);
5796 #endif
5797     }
5798     else if (gimme != G_ARRAY)
5799 #ifdef USE_THREADS
5800         ary = (AV*)PL_curpad[0];
5801 #else
5802         ary = GvAVn(PL_defgv);
5803 #endif /* USE_THREADS */
5804     else
5805         ary = Nullav;
5806     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5807         realarray = 1;
5808         PUTBACK;
5809         av_extend(ary,0);
5810         av_clear(ary);
5811         SPAGAIN;
5812         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5813             PUSHMARK(SP);
5814             XPUSHs(SvTIED_obj((SV*)ary, mg));
5815         }
5816         else {
5817             if (!AvREAL(ary)) {
5818                 AvREAL_on(ary);
5819                 AvREIFY_off(ary);
5820                 for (i = AvFILLp(ary); i >= 0; i--)
5821                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5822             }
5823             /* temporarily switch stacks */
5824             SWITCHSTACK(PL_curstack, ary);
5825             make_mortal = 0;
5826         }
5827     }
5828     base = SP - PL_stack_base;
5829     orig = s;
5830     if (pm->op_pmflags & PMf_SKIPWHITE) {
5831         if (pm->op_pmflags & PMf_LOCALE) {
5832             while (isSPACE_LC(*s))
5833                 s++;
5834         }
5835         else {
5836             while (isSPACE(*s))
5837                 s++;
5838         }
5839     }
5840     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5841         SAVEINT(PL_multiline);
5842         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5843     }
5844
5845     if (!limit)
5846         limit = maxiters + 2;
5847     if (pm->op_pmflags & PMf_WHITE) {
5848         while (--limit) {
5849             m = s;
5850             while (m < strend &&
5851                    !((pm->op_pmflags & PMf_LOCALE)
5852                      ? isSPACE_LC(*m) : isSPACE(*m)))
5853                 ++m;
5854             if (m >= strend)
5855                 break;
5856
5857             dstr = NEWSV(30, m-s);
5858             sv_setpvn(dstr, s, m-s);
5859             if (make_mortal)
5860                 sv_2mortal(dstr);
5861             if (do_utf8)
5862                 (void)SvUTF8_on(dstr);
5863             XPUSHs(dstr);
5864
5865             s = m + 1;
5866             while (s < strend &&
5867                    ((pm->op_pmflags & PMf_LOCALE)
5868                     ? isSPACE_LC(*s) : isSPACE(*s)))
5869                 ++s;
5870         }
5871     }
5872     else if (strEQ("^", rx->precomp)) {
5873         while (--limit) {
5874             /*SUPPRESS 530*/
5875             for (m = s; m < strend && *m != '\n'; m++) ;
5876             m++;
5877             if (m >= strend)
5878                 break;
5879             dstr = NEWSV(30, m-s);
5880             sv_setpvn(dstr, s, m-s);
5881             if (make_mortal)
5882                 sv_2mortal(dstr);
5883             if (do_utf8)
5884                 (void)SvUTF8_on(dstr);
5885             XPUSHs(dstr);
5886             s = m;
5887         }
5888     }
5889     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5890              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5891              && (rx->reganch & ROPT_CHECK_ALL)
5892              && !(rx->reganch & ROPT_ANCH)) {
5893         int tail = (rx->reganch & RE_INTUIT_TAIL);
5894         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5895
5896         len = rx->minlen;
5897         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5898             STRLEN n_a;
5899             char c = *SvPV(csv, n_a);
5900             while (--limit) {
5901                 /*SUPPRESS 530*/
5902                 for (m = s; m < strend && *m != c; m++) ;
5903                 if (m >= strend)
5904                     break;
5905                 dstr = NEWSV(30, m-s);
5906                 sv_setpvn(dstr, s, m-s);
5907                 if (make_mortal)
5908                     sv_2mortal(dstr);
5909                 if (do_utf8)
5910                     (void)SvUTF8_on(dstr);
5911                 XPUSHs(dstr);
5912                 /* The rx->minlen is in characters but we want to step
5913                  * s ahead by bytes. */
5914                 if (do_utf8)
5915                     s = (char*)utf8_hop((U8*)m, len);
5916                 else
5917                     s = m + len; /* Fake \n at the end */
5918             }
5919         }
5920         else {
5921 #ifndef lint
5922             while (s < strend && --limit &&
5923               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5924                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5925 #endif
5926             {
5927                 dstr = NEWSV(31, m-s);
5928                 sv_setpvn(dstr, s, m-s);
5929                 if (make_mortal)
5930                     sv_2mortal(dstr);
5931                 if (do_utf8)
5932                     (void)SvUTF8_on(dstr);
5933                 XPUSHs(dstr);
5934                 /* The rx->minlen is in characters but we want to step
5935                  * s ahead by bytes. */
5936                 if (do_utf8)
5937                     s = (char*)utf8_hop((U8*)m, len);
5938                 else
5939                     s = m + len; /* Fake \n at the end */
5940             }
5941         }
5942     }
5943     else {
5944         maxiters += slen * rx->nparens;
5945         while (s < strend && --limit
5946 /*             && (!rx->check_substr
5947                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5948                                                  0, NULL))))
5949 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5950                               1 /* minend */, sv, NULL, 0))
5951         {
5952             TAINT_IF(RX_MATCH_TAINTED(rx));
5953             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5954                 m = s;
5955                 s = orig;
5956                 orig = rx->subbeg;
5957                 s = orig + (m - s);
5958                 strend = s + (strend - m);
5959             }
5960             m = rx->startp[0] + orig;
5961             dstr = NEWSV(32, m-s);
5962             sv_setpvn(dstr, s, m-s);
5963             if (make_mortal)
5964                 sv_2mortal(dstr);
5965             if (do_utf8)
5966                 (void)SvUTF8_on(dstr);
5967             XPUSHs(dstr);
5968             if (rx->nparens) {
5969                 for (i = 1; i <= rx->nparens; i++) {
5970                     s = rx->startp[i] + orig;
5971                     m = rx->endp[i] + orig;
5972                     if (m && s) {
5973                         dstr = NEWSV(33, m-s);
5974                         sv_setpvn(dstr, s, m-s);
5975                     }
5976                     else
5977                         dstr = NEWSV(33, 0);
5978                     if (make_mortal)
5979                         sv_2mortal(dstr);
5980                     if (do_utf8)
5981                         (void)SvUTF8_on(dstr);
5982                     XPUSHs(dstr);
5983                 }
5984             }
5985             s = rx->endp[0] + orig;
5986         }
5987     }
5988
5989     LEAVE_SCOPE(oldsave);
5990     iters = (SP - PL_stack_base) - base;
5991     if (iters > maxiters)
5992         DIE(aTHX_ "Split loop");
5993
5994     /* keep field after final delim? */
5995     if (s < strend || (iters && origlimit)) {
5996         STRLEN l = strend - s;
5997         dstr = NEWSV(34, l);
5998         sv_setpvn(dstr, s, l);
5999         if (make_mortal)
6000             sv_2mortal(dstr);
6001         if (do_utf8)
6002             (void)SvUTF8_on(dstr);
6003         XPUSHs(dstr);
6004         iters++;
6005     }
6006     else if (!origlimit) {
6007         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6008             iters--, SP--;
6009     }
6010
6011     if (realarray) {
6012         if (!mg) {
6013             SWITCHSTACK(ary, oldstack);
6014             if (SvSMAGICAL(ary)) {
6015                 PUTBACK;
6016                 mg_set((SV*)ary);
6017                 SPAGAIN;
6018             }
6019             if (gimme == G_ARRAY) {
6020                 EXTEND(SP, iters);
6021                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6022                 SP += iters;
6023                 RETURN;
6024             }
6025         }
6026         else {
6027             PUTBACK;
6028             ENTER;
6029             call_method("PUSH",G_SCALAR|G_DISCARD);
6030             LEAVE;
6031             SPAGAIN;
6032             if (gimme == G_ARRAY) {
6033                 /* EXTEND should not be needed - we just popped them */
6034                 EXTEND(SP, iters);
6035                 for (i=0; i < iters; i++) {
6036                     SV **svp = av_fetch(ary, i, FALSE);
6037                     PUSHs((svp) ? *svp : &PL_sv_undef);
6038                 }
6039                 RETURN;
6040             }
6041         }
6042     }
6043     else {
6044         if (gimme == G_ARRAY)
6045             RETURN;
6046     }
6047     if (iters || !pm->op_pmreplroot) {
6048         GETTARGET;
6049         PUSHi(iters);
6050         RETURN;
6051     }
6052     RETPUSHUNDEF;
6053 }
6054
6055 #ifdef USE_THREADS
6056 void
6057 Perl_unlock_condpair(pTHX_ void *svv)
6058 {
6059     MAGIC *mg = mg_find((SV*)svv, 'm');
6060
6061     if (!mg)
6062         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6063     MUTEX_LOCK(MgMUTEXP(mg));
6064     if (MgOWNER(mg) != thr)
6065         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6066     MgOWNER(mg) = 0;
6067     COND_SIGNAL(MgOWNERCONDP(mg));
6068     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6069                           PTR2UV(thr), PTR2UV(svv));)
6070     MUTEX_UNLOCK(MgMUTEXP(mg));
6071 }
6072 #endif /* USE_THREADS */
6073
6074 PP(pp_lock)
6075 {
6076     djSP;
6077     dTOPss;
6078     SV *retsv = sv;
6079 #ifdef USE_THREADS
6080     sv_lock(sv);
6081 #endif /* USE_THREADS */
6082     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6083         || SvTYPE(retsv) == SVt_PVCV) {
6084         retsv = refto(retsv);
6085     }
6086     SETs(retsv);
6087     RETURN;
6088 }
6089
6090 PP(pp_threadsv)
6091 {
6092 #ifdef USE_THREADS
6093     djSP;
6094     EXTEND(SP, 1);
6095     if (PL_op->op_private & OPpLVAL_INTRO)
6096         PUSHs(*save_threadsv(PL_op->op_targ));
6097     else
6098         PUSHs(THREADSV(PL_op->op_targ));
6099     RETURN;
6100 #else
6101     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6102 #endif /* USE_THREADS */
6103 }