pp.c

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