pp.c

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