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