pp.c

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