pp.c

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