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