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