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