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         ENTER;
2465         perl_call_method("SPLICE",GIMME_V);
2466         LEAVE;
2467         SPAGAIN;
2468         RETURN;
2469     }
2470
2471     SP++;
2472
2473     if (++MARK < SP) {
2474         offset = i = SvIVx(*MARK);
2475         if (offset < 0)
2476             offset += AvFILLp(ary) + 1;
2477         else
2478             offset -= curcop->cop_arybase;
2479         if (offset < 0)
2480             DIE(no_aelem, i);
2481         if (++MARK < SP) {
2482             length = SvIVx(*MARK++);
2483             if (length < 0)
2484                 length = 0;
2485         }
2486         else
2487             length = AvMAX(ary) + 1;            /* close enough to infinity */
2488     }
2489     else {
2490         offset = 0;
2491         length = AvMAX(ary) + 1;
2492     }
2493     if (offset > AvFILLp(ary) + 1)
2494         offset = AvFILLp(ary) + 1;
2495     after = AvFILLp(ary) + 1 - (offset + length);
2496     if (after < 0) {                            /* not that much array */
2497         length += after;                        /* offset+length now in array */
2498         after = 0;
2499         if (!AvALLOC(ary))
2500             av_extend(ary, 0);
2501     }
2502
2503     /* At this point, MARK .. SP-1 is our new LIST */
2504
2505     newlen = SP - MARK;
2506     diff = newlen - length;
2507     if (newlen && !AvREAL(ary)) {
2508         if (AvREIFY(ary))
2509             av_reify(ary);
2510         else
2511             assert(AvREAL(ary));                /* would leak, so croak */
2512     }
2513
2514     if (diff < 0) {                             /* shrinking the area */
2515         if (newlen) {
2516             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2517             Copy(MARK, tmparyval, newlen, SV*);
2518         }
2519
2520         MARK = ORIGMARK + 1;
2521         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2522             MEXTEND(MARK, length);
2523             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2524             if (AvREAL(ary)) {
2525                 EXTEND_MORTAL(length);
2526                 for (i = length, dst = MARK; i; i--) {
2527                     if (!SvIMMORTAL(*dst))
2528                         sv_2mortal(*dst);       /* free them eventualy */
2529                     dst++;
2530                 }
2531             }
2532             MARK += length - 1;
2533         }
2534         else {
2535             *MARK = AvARRAY(ary)[offset+length-1];
2536             if (AvREAL(ary)) {
2537                 if (!SvIMMORTAL(*MARK))
2538                     sv_2mortal(*MARK);
2539                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2540                     SvREFCNT_dec(*dst++);       /* free them now */
2541             }
2542         }
2543         AvFILLp(ary) += diff;
2544
2545         /* pull up or down? */
2546
2547         if (offset < after) {                   /* easier to pull up */
2548             if (offset) {                       /* esp. if nothing to pull */
2549                 src = &AvARRAY(ary)[offset-1];
2550                 dst = src - diff;               /* diff is negative */
2551                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2552                     *dst-- = *src--;
2553             }
2554             dst = AvARRAY(ary);
2555             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2556             AvMAX(ary) += diff;
2557         }
2558         else {
2559             if (after) {                        /* anything to pull down? */
2560                 src = AvARRAY(ary) + offset + length;
2561                 dst = src + diff;               /* diff is negative */
2562                 Move(src, dst, after, SV*);
2563             }
2564             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2565                                                 /* avoid later double free */
2566         }
2567         i = -diff;
2568         while (i)
2569             dst[--i] = &sv_undef;
2570
2571         if (newlen) {
2572             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2573               newlen; newlen--) {
2574                 *dst = NEWSV(46, 0);
2575                 sv_setsv(*dst++, *src++);
2576             }
2577             Safefree(tmparyval);
2578         }
2579     }
2580     else {                                      /* no, expanding (or same) */
2581         if (length) {
2582             New(452, tmparyval, length, SV*);   /* so remember deletion */
2583             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2584         }
2585
2586         if (diff > 0) {                         /* expanding */
2587
2588             /* push up or down? */
2589
2590             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2591                 if (offset) {
2592                     src = AvARRAY(ary);
2593                     dst = src - diff;
2594                     Move(src, dst, offset, SV*);
2595                 }
2596                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2597                 AvMAX(ary) += diff;
2598                 AvFILLp(ary) += diff;
2599             }
2600             else {
2601                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2602                     av_extend(ary, AvFILLp(ary) + diff);
2603                 AvFILLp(ary) += diff;
2604
2605                 if (after) {
2606                     dst = AvARRAY(ary) + AvFILLp(ary);
2607                     src = dst - diff;
2608                     for (i = after; i; i--) {
2609                         *dst-- = *src--;
2610                     }
2611                 }
2612             }
2613         }
2614
2615         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2616             *dst = NEWSV(46, 0);
2617             sv_setsv(*dst++, *src++);
2618         }
2619         MARK = ORIGMARK + 1;
2620         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2621             if (length) {
2622                 Copy(tmparyval, MARK, length, SV*);
2623                 if (AvREAL(ary)) {
2624                     EXTEND_MORTAL(length);
2625                     for (i = length, dst = MARK; i; i--) {
2626                         if (!SvIMMORTAL(*dst))
2627                             sv_2mortal(*dst);   /* free them eventualy */
2628                         dst++;
2629                     }
2630                 }
2631                 Safefree(tmparyval);
2632             }
2633             MARK += length - 1;
2634         }
2635         else if (length--) {
2636             *MARK = tmparyval[length];
2637             if (AvREAL(ary)) {
2638                 if (!SvIMMORTAL(*MARK))
2639                     sv_2mortal(*MARK);
2640                 while (length-- > 0)
2641                     SvREFCNT_dec(tmparyval[length]);
2642             }
2643             Safefree(tmparyval);
2644         }
2645         else
2646             *MARK = &sv_undef;
2647     }
2648     SP = MARK;
2649     RETURN;
2650 }
2651
2652 PP(pp_push)
2653 {
2654     djSP; dMARK; dORIGMARK; dTARGET;
2655     register AV *ary = (AV*)*++MARK;
2656     register SV *sv = &sv_undef;
2657     MAGIC *mg;
2658
2659     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2660         *MARK-- = mg->mg_obj;
2661         PUSHMARK(MARK);
2662         PUTBACK;
2663         ENTER;
2664         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2665         LEAVE;
2666         SPAGAIN;
2667     }
2668     else {
2669         /* Why no pre-extend of ary here ? */
2670         for (++MARK; MARK <= SP; MARK++) {
2671             sv = NEWSV(51, 0);
2672             if (*MARK)
2673                 sv_setsv(sv, *MARK);
2674             av_push(ary, sv);
2675         }
2676     }
2677     SP = ORIGMARK;
2678     PUSHi( AvFILL(ary) + 1 );
2679     RETURN;
2680 }
2681
2682 PP(pp_pop)
2683 {
2684     djSP;
2685     AV *av = (AV*)POPs;
2686     SV *sv = av_pop(av);
2687     if (!SvIMMORTAL(sv) && AvREAL(av))
2688         (void)sv_2mortal(sv);
2689     PUSHs(sv);
2690     RETURN;
2691 }
2692
2693 PP(pp_shift)
2694 {
2695     djSP;
2696     AV *av = (AV*)POPs;
2697     SV *sv = av_shift(av);
2698     EXTEND(SP, 1);
2699     if (!sv)
2700         RETPUSHUNDEF;
2701     if (!SvIMMORTAL(sv) && AvREAL(av))
2702         (void)sv_2mortal(sv);
2703     PUSHs(sv);
2704     RETURN;
2705 }
2706
2707 PP(pp_unshift)
2708 {
2709     djSP; dMARK; dORIGMARK; dTARGET;
2710     register AV *ary = (AV*)*++MARK;
2711     register SV *sv;
2712     register I32 i = 0;
2713     MAGIC *mg;
2714
2715     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2716
2717
2718         *MARK-- = mg->mg_obj;
2719         PUTBACK;
2720         ENTER;
2721         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2722         LEAVE;
2723         SPAGAIN;
2724     }
2725     else {
2726         av_unshift(ary, SP - MARK);
2727         while (MARK < SP) {
2728             sv = NEWSV(27, 0);
2729             sv_setsv(sv, *++MARK);
2730             (void)av_store(ary, i++, sv);
2731         }
2732     }
2733     SP = ORIGMARK;
2734     PUSHi( AvFILL(ary) + 1 );
2735     RETURN;
2736 }
2737
2738 PP(pp_reverse)
2739 {
2740     djSP; dMARK;
2741     register SV *tmp;
2742     SV **oldsp = SP;
2743
2744     if (GIMME == G_ARRAY) {
2745         MARK++;
2746         while (MARK < SP) {
2747             tmp = *MARK;
2748             *MARK++ = *SP;
2749             *SP-- = tmp;
2750         }
2751         SP = oldsp;
2752     }
2753     else {
2754         register char *up;
2755         register char *down;
2756         register I32 tmp;
2757         dTARGET;
2758         STRLEN len;
2759
2760         if (SP - MARK > 1)
2761             do_join(TARG, &sv_no, MARK, SP);
2762         else
2763             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2764         up = SvPV_force(TARG, len);
2765         if (len > 1) {
2766             down = SvPVX(TARG) + len - 1;
2767             while (down > up) {
2768                 tmp = *up;
2769                 *up++ = *down;
2770                 *down-- = tmp;
2771             }
2772             (void)SvPOK_only(TARG);
2773         }
2774         SP = MARK + 1;
2775         SETTARG;
2776     }
2777     RETURN;
2778 }
2779
2780 static SV      *
2781 mul128(SV *sv, U8 m)
2782 {
2783   STRLEN          len;
2784   char           *s = SvPV(sv, len);
2785   char           *t;
2786   U32             i = 0;
2787
2788   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
2789     SV             *New = newSVpv("0000000000", 10);
2790
2791     sv_catsv(New, sv);
2792     SvREFCNT_dec(sv);           /* free old sv */
2793     sv = New;
2794     s = SvPV(sv, len);
2795   }
2796   t = s + len - 1;
2797   while (!*t)                   /* trailing '\0'? */
2798     t--;
2799   while (t > s) {
2800     i = ((*t - '0') << 7) + m;
2801     *(t--) = '0' + (i % 10);
2802     m = i / 10;
2803   }
2804   return (sv);
2805 }
2806
2807 /* Explosives and implosives. */
2808
2809 PP(pp_unpack)
2810 {
2811     djSP;
2812     dPOPPOPssrl;
2813     SV **oldsp = sp;
2814     I32 gimme = GIMME_V;
2815     SV *sv;
2816     STRLEN llen;
2817     STRLEN rlen;
2818     register char *pat = SvPV(left, llen);
2819     register char *s = SvPV(right, rlen);
2820     char *strend = s + rlen;
2821     char *strbeg = s;
2822     register char *patend = pat + llen;
2823     I32 datumtype;
2824     register I32 len;
2825     register I32 bits;
2826
2827     /* These must not be in registers: */
2828     I16 ashort;
2829     int aint;
2830     I32 along;
2831 #ifdef HAS_QUAD
2832     Quad_t aquad;
2833 #endif
2834     U16 aushort;
2835     unsigned int auint;
2836     U32 aulong;
2837 #ifdef HAS_QUAD
2838     unsigned Quad_t auquad;
2839 #endif
2840     char *aptr;
2841     float afloat;
2842     double adouble;
2843     I32 checksum = 0;
2844     register U32 culong;
2845     double cdouble;
2846     static char* bitcount = 0;
2847     int commas = 0;
2848
2849     if (gimme != G_ARRAY) {             /* arrange to do first one only */
2850         /*SUPPRESS 530*/
2851         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2852         if (strchr("aAbBhHP", *patend) || *pat == '%') {
2853             patend++;
2854             while (isDIGIT(*patend) || *patend == '*')
2855                 patend++;
2856         }
2857         else
2858             patend++;
2859     }
2860     while (pat < patend) {
2861       reparse:
2862         datumtype = *pat++ & 0xFF;
2863         if (isSPACE(datumtype))
2864             continue;
2865         if (pat >= patend)
2866             len = 1;
2867         else if (*pat == '*') {
2868             len = strend - strbeg;      /* long enough */
2869             pat++;
2870         }
2871         else if (isDIGIT(*pat)) {
2872             len = *pat++ - '0';
2873             while (isDIGIT(*pat))
2874                 len = (len * 10) + (*pat++ - '0');
2875         }
2876         else
2877             len = (datumtype != '@');
2878         switch(datumtype) {
2879         default:
2880             croak("Invalid type in unpack: '%c'", (int)datumtype);
2881         case ',': /* grandfather in commas but with a warning */
2882             if (commas++ == 0 && dowarn)
2883                 warn("Invalid type in unpack: '%c'", (int)datumtype);
2884             break;
2885         case '%':
2886             if (len == 1 && pat[-1] != '1')
2887                 len = 16;
2888             checksum = len;
2889             culong = 0;
2890             cdouble = 0;
2891             if (pat < patend)
2892                 goto reparse;
2893             break;
2894         case '@':
2895             if (len > strend - strbeg)
2896                 DIE("@ outside of string");
2897             s = strbeg + len;
2898             break;
2899         case 'X':
2900             if (len > s - strbeg)
2901                 DIE("X outside of string");
2902             s -= len;
2903             break;
2904         case 'x':
2905             if (len > strend - s)
2906                 DIE("x outside of string");
2907             s += len;
2908             break;
2909         case 'A':
2910         case 'a':
2911             if (len > strend - s)
2912                 len = strend - s;
2913             if (checksum)
2914                 goto uchar_checksum;
2915             sv = NEWSV(35, len);
2916             sv_setpvn(sv, s, len);
2917             s += len;
2918             if (datumtype == 'A') {
2919                 aptr = s;       /* borrow register */
2920                 s = SvPVX(sv) + len - 1;
2921                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2922                     s--;
2923                 *++s = '\0';
2924                 SvCUR_set(sv, s - SvPVX(sv));
2925                 s = aptr;       /* unborrow register */
2926             }
2927             XPUSHs(sv_2mortal(sv));
2928             break;
2929         case 'B':
2930         case 'b':
2931             if (pat[-1] == '*' || len > (strend - s) * 8)
2932                 len = (strend - s) * 8;
2933             if (checksum) {
2934                 if (!bitcount) {
2935                     Newz(601, bitcount, 256, char);
2936                     for (bits = 1; bits < 256; bits++) {
2937                         if (bits & 1)   bitcount[bits]++;
2938                         if (bits & 2)   bitcount[bits]++;
2939                         if (bits & 4)   bitcount[bits]++;
2940                         if (bits & 8)   bitcount[bits]++;
2941                         if (bits & 16)  bitcount[bits]++;
2942                         if (bits & 32)  bitcount[bits]++;
2943                         if (bits & 64)  bitcount[bits]++;
2944                         if (bits & 128) bitcount[bits]++;
2945                     }
2946                 }
2947                 while (len >= 8) {
2948                     culong += bitcount[*(unsigned char*)s++];
2949                     len -= 8;
2950                 }
2951                 if (len) {
2952                     bits = *s;
2953                     if (datumtype == 'b') {
2954                         while (len-- > 0) {
2955                             if (bits & 1) culong++;
2956                             bits >>= 1;
2957                         }
2958                     }
2959                     else {
2960                         while (len-- > 0) {
2961                             if (bits & 128) culong++;
2962                             bits <<= 1;
2963                         }
2964                     }
2965                 }
2966                 break;
2967             }
2968             sv = NEWSV(35, len + 1);
2969             SvCUR_set(sv, len);
2970             SvPOK_on(sv);
2971             aptr = pat;                 /* borrow register */
2972             pat = SvPVX(sv);
2973             if (datumtype == 'b') {
2974                 aint = len;
2975                 for (len = 0; len < aint; len++) {
2976                     if (len & 7)                /*SUPPRESS 595*/
2977                         bits >>= 1;
2978                     else
2979                         bits = *s++;
2980                     *pat++ = '0' + (bits & 1);
2981                 }
2982             }
2983             else {
2984                 aint = len;
2985                 for (len = 0; len < aint; len++) {
2986                     if (len & 7)
2987                         bits <<= 1;
2988                     else
2989                         bits = *s++;
2990                     *pat++ = '0' + ((bits & 128) != 0);
2991                 }
2992             }
2993             *pat = '\0';
2994             pat = aptr;                 /* unborrow register */
2995             XPUSHs(sv_2mortal(sv));
2996             break;
2997         case 'H':
2998         case 'h':
2999             if (pat[-1] == '*' || len > (strend - s) * 2)
3000                 len = (strend - s) * 2;
3001             sv = NEWSV(35, len + 1);
3002             SvCUR_set(sv, len);
3003             SvPOK_on(sv);
3004             aptr = pat;                 /* borrow register */
3005             pat = SvPVX(sv);
3006             if (datumtype == 'h') {
3007                 aint = len;
3008                 for (len = 0; len < aint; len++) {
3009                     if (len & 1)
3010                         bits >>= 4;
3011                     else
3012                         bits = *s++;
3013                     *pat++ = hexdigit[bits & 15];
3014                 }
3015             }
3016             else {
3017                 aint = len;
3018                 for (len = 0; len < aint; len++) {
3019                     if (len & 1)
3020                         bits <<= 4;
3021                     else
3022                         bits = *s++;
3023                     *pat++ = hexdigit[(bits >> 4) & 15];
3024                 }
3025             }
3026             *pat = '\0';
3027             pat = aptr;                 /* unborrow register */
3028             XPUSHs(sv_2mortal(sv));
3029             break;
3030         case 'c':
3031             if (len > strend - s)
3032                 len = strend - s;
3033             if (checksum) {
3034                 while (len-- > 0) {
3035                     aint = *s++;
3036                     if (aint >= 128)    /* fake up signed chars */
3037                         aint -= 256;
3038                     culong += aint;
3039                 }
3040             }
3041             else {
3042                 EXTEND(SP, len);
3043                 EXTEND_MORTAL(len);
3044                 while (len-- > 0) {
3045                     aint = *s++;
3046                     if (aint >= 128)    /* fake up signed chars */
3047                         aint -= 256;
3048                     sv = NEWSV(36, 0);
3049                     sv_setiv(sv, (IV)aint);
3050                     PUSHs(sv_2mortal(sv));
3051                 }
3052             }
3053             break;
3054         case 'C':
3055             if (len > strend - s)
3056                 len = strend - s;
3057             if (checksum) {
3058               uchar_checksum:
3059                 while (len-- > 0) {
3060                     auint = *s++ & 255;
3061                     culong += auint;
3062                 }
3063             }
3064             else {
3065                 EXTEND(SP, len);
3066                 EXTEND_MORTAL(len);
3067                 while (len-- > 0) {
3068                     auint = *s++ & 255;
3069                     sv = NEWSV(37, 0);
3070                     sv_setiv(sv, (IV)auint);
3071                     PUSHs(sv_2mortal(sv));
3072                 }
3073             }
3074             break;
3075         case 's':
3076             along = (strend - s) / SIZE16;
3077             if (len > along)
3078                 len = along;
3079             if (checksum) {
3080                 while (len-- > 0) {
3081                     COPY16(s, &ashort);
3082                     s += SIZE16;
3083                     culong += ashort;
3084                 }
3085             }
3086             else {
3087                 EXTEND(SP, len);
3088                 EXTEND_MORTAL(len);
3089                 while (len-- > 0) {
3090                     COPY16(s, &ashort);
3091                     s += SIZE16;
3092                     sv = NEWSV(38, 0);
3093                     sv_setiv(sv, (IV)ashort);
3094                     PUSHs(sv_2mortal(sv));
3095                 }
3096             }
3097             break;
3098         case 'v':
3099         case 'n':
3100         case 'S':
3101             along = (strend - s) / SIZE16;
3102             if (len > along)
3103                 len = along;
3104             if (checksum) {
3105                 while (len-- > 0) {
3106                     COPY16(s, &aushort);
3107                     s += SIZE16;
3108 #ifdef HAS_NTOHS
3109                     if (datumtype == 'n')
3110                         aushort = PerlSock_ntohs(aushort);
3111 #endif
3112 #ifdef HAS_VTOHS
3113                     if (datumtype == 'v')
3114                         aushort = vtohs(aushort);
3115 #endif
3116                     culong += aushort;
3117                 }
3118             }
3119             else {
3120                 EXTEND(SP, len);
3121                 EXTEND_MORTAL(len);
3122                 while (len-- > 0) {
3123                     COPY16(s, &aushort);
3124                     s += SIZE16;
3125                     sv = NEWSV(39, 0);
3126 #ifdef HAS_NTOHS
3127                     if (datumtype == 'n')
3128                         aushort = PerlSock_ntohs(aushort);
3129 #endif
3130 #ifdef HAS_VTOHS
3131                     if (datumtype == 'v')
3132                         aushort = vtohs(aushort);
3133 #endif
3134                     sv_setiv(sv, (IV)aushort);
3135                     PUSHs(sv_2mortal(sv));
3136                 }
3137             }
3138             break;
3139         case 'i':
3140             along = (strend - s) / sizeof(int);
3141             if (len > along)
3142                 len = along;
3143             if (checksum) {
3144                 while (len-- > 0) {
3145                     Copy(s, &aint, 1, int);
3146                     s += sizeof(int);
3147                     if (checksum > 32)
3148                         cdouble += (double)aint;
3149                     else
3150                         culong += aint;
3151                 }
3152             }
3153             else {
3154                 EXTEND(SP, len);
3155                 EXTEND_MORTAL(len);
3156                 while (len-- > 0) {
3157                     Copy(s, &aint, 1, int);
3158                     s += sizeof(int);
3159                     sv = NEWSV(40, 0);
3160                     sv_setiv(sv, (IV)aint);
3161                     PUSHs(sv_2mortal(sv));
3162                 }
3163             }
3164             break;
3165         case 'I':
3166             along = (strend - s) / sizeof(unsigned int);
3167             if (len > along)
3168                 len = along;
3169             if (checksum) {
3170                 while (len-- > 0) {
3171                     Copy(s, &auint, 1, unsigned int);
3172                     s += sizeof(unsigned int);
3173                     if (checksum > 32)
3174                         cdouble += (double)auint;
3175                     else
3176                         culong += auint;
3177                 }
3178             }
3179             else {
3180                 EXTEND(SP, len);
3181                 EXTEND_MORTAL(len);
3182                 while (len-- > 0) {
3183                     Copy(s, &auint, 1, unsigned int);
3184                     s += sizeof(unsigned int);
3185                     sv = NEWSV(41, 0);
3186                     sv_setuv(sv, (UV)auint);
3187                     PUSHs(sv_2mortal(sv));
3188                 }
3189             }
3190             break;
3191         case 'l':
3192             along = (strend - s) / SIZE32;
3193             if (len > along)
3194                 len = along;
3195             if (checksum) {
3196                 while (len-- > 0) {
3197                     COPY32(s, &along);
3198                     s += SIZE32;
3199                     if (checksum > 32)
3200                         cdouble += (double)along;
3201                     else
3202                         culong += along;
3203                 }
3204             }
3205             else {
3206                 EXTEND(SP, len);
3207                 EXTEND_MORTAL(len);
3208                 while (len-- > 0) {
3209                     COPY32(s, &along);
3210                     s += SIZE32;
3211                     sv = NEWSV(42, 0);
3212                     sv_setiv(sv, (IV)along);
3213                     PUSHs(sv_2mortal(sv));
3214                 }
3215             }
3216             break;
3217         case 'V':
3218         case 'N':
3219         case 'L':
3220             along = (strend - s) / SIZE32;
3221             if (len > along)
3222                 len = along;
3223             if (checksum) {
3224                 while (len-- > 0) {
3225                     COPY32(s, &aulong);
3226                     s += SIZE32;
3227 #ifdef HAS_NTOHL
3228                     if (datumtype == 'N')
3229                         aulong = PerlSock_ntohl(aulong);
3230 #endif
3231 #ifdef HAS_VTOHL
3232                     if (datumtype == 'V')
3233                         aulong = vtohl(aulong);
3234 #endif
3235                     if (checksum > 32)
3236                         cdouble += (double)aulong;
3237                     else
3238                         culong += aulong;
3239                 }
3240             }
3241             else {
3242                 EXTEND(SP, len);
3243                 EXTEND_MORTAL(len);
3244                 while (len-- > 0) {
3245                     COPY32(s, &aulong);
3246                     s += SIZE32;
3247 #ifdef HAS_NTOHL
3248                     if (datumtype == 'N')
3249                         aulong = PerlSock_ntohl(aulong);
3250 #endif
3251 #ifdef HAS_VTOHL
3252                     if (datumtype == 'V')
3253                         aulong = vtohl(aulong);
3254 #endif
3255                     sv = NEWSV(43, 0);
3256                     sv_setuv(sv, (UV)aulong);
3257                     PUSHs(sv_2mortal(sv));
3258                 }
3259             }
3260             break;
3261         case 'p':
3262             along = (strend - s) / sizeof(char*);
3263             if (len > along)
3264                 len = along;
3265             EXTEND(SP, len);
3266             EXTEND_MORTAL(len);
3267             while (len-- > 0) {
3268                 if (sizeof(char*) > strend - s)
3269                     break;
3270                 else {
3271                     Copy(s, &aptr, 1, char*);
3272                     s += sizeof(char*);
3273                 }
3274                 sv = NEWSV(44, 0);
3275                 if (aptr)
3276                     sv_setpv(sv, aptr);
3277                 PUSHs(sv_2mortal(sv));
3278             }
3279             break;
3280         case 'w':
3281             EXTEND(SP, len);
3282             EXTEND_MORTAL(len);
3283             {
3284                 UV auv = 0;
3285                 U32 bytes = 0;
3286
3287                 while ((len > 0) && (s < strend)) {
3288                     auv = (auv << 7) | (*s & 0x7f);
3289                     if (!(*s++ & 0x80)) {
3290                         bytes = 0;
3291                         sv = NEWSV(40, 0);
3292                         sv_setuv(sv, auv);
3293                         PUSHs(sv_2mortal(sv));
3294                         len--;
3295                         auv = 0;
3296                     }
3297                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3298                         char *t;
3299
3300                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3301                         while (s < strend) {
3302                             sv = mul128(sv, *s & 0x7f);
3303                             if (!(*s++ & 0x80)) {
3304                                 bytes = 0;
3305                                 break;
3306                             }
3307                         }
3308                         t = SvPV(sv, na);
3309                         while (*t == '0')
3310                             t++;
3311                         sv_chop(sv, t);
3312                         PUSHs(sv_2mortal(sv));
3313                         len--;
3314                         auv = 0;
3315                     }
3316                 }
3317                 if ((s >= strend) && bytes)
3318                     croak("Unterminated compressed integer");
3319             }
3320             break;
3321         case 'P':
3322             EXTEND(SP, 1);
3323             if (sizeof(char*) > strend - s)
3324                 break;
3325             else {
3326                 Copy(s, &aptr, 1, char*);
3327                 s += sizeof(char*);
3328             }
3329             sv = NEWSV(44, 0);
3330             if (aptr)
3331                 sv_setpvn(sv, aptr, len);
3332             PUSHs(sv_2mortal(sv));
3333             break;
3334 #ifdef HAS_QUAD
3335         case 'q':
3336             EXTEND(SP, len);
3337             EXTEND_MORTAL(len);
3338             while (len-- > 0) {
3339                 if (s + sizeof(Quad_t) > strend)
3340                     aquad = 0;
3341                 else {
3342                     Copy(s, &aquad, 1, Quad_t);
3343                     s += sizeof(Quad_t);
3344                 }
3345                 sv = NEWSV(42, 0);
3346                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3347                     sv_setiv(sv, (IV)aquad);
3348                 else
3349                     sv_setnv(sv, (double)aquad);
3350                 PUSHs(sv_2mortal(sv));
3351             }
3352             break;
3353         case 'Q':
3354             EXTEND(SP, len);
3355             EXTEND_MORTAL(len);
3356             while (len-- > 0) {
3357                 if (s + sizeof(unsigned Quad_t) > strend)
3358                     auquad = 0;
3359                 else {
3360                     Copy(s, &auquad, 1, unsigned Quad_t);
3361                     s += sizeof(unsigned Quad_t);
3362                 }
3363                 sv = NEWSV(43, 0);
3364                 if (aquad <= UV_MAX)
3365                     sv_setuv(sv, (UV)auquad);
3366                 else
3367                     sv_setnv(sv, (double)auquad);
3368                 PUSHs(sv_2mortal(sv));
3369             }
3370             break;
3371 #endif
3372         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3373         case 'f':
3374         case 'F':
3375             along = (strend - s) / sizeof(float);
3376             if (len > along)
3377                 len = along;
3378             if (checksum) {
3379                 while (len-- > 0) {
3380                     Copy(s, &afloat, 1, float);
3381                     s += sizeof(float);
3382                     cdouble += afloat;
3383                 }
3384             }
3385             else {
3386                 EXTEND(SP, len);
3387                 EXTEND_MORTAL(len);
3388                 while (len-- > 0) {
3389                     Copy(s, &afloat, 1, float);
3390                     s += sizeof(float);
3391                     sv = NEWSV(47, 0);
3392                     sv_setnv(sv, (double)afloat);
3393                     PUSHs(sv_2mortal(sv));
3394                 }
3395             }
3396             break;
3397         case 'd':
3398         case 'D':
3399             along = (strend - s) / sizeof(double);
3400             if (len > along)
3401                 len = along;
3402             if (checksum) {
3403                 while (len-- > 0) {
3404                     Copy(s, &adouble, 1, double);
3405                     s += sizeof(double);
3406                     cdouble += adouble;
3407                 }
3408             }
3409             else {
3410                 EXTEND(SP, len);
3411                 EXTEND_MORTAL(len);
3412                 while (len-- > 0) {
3413                     Copy(s, &adouble, 1, double);
3414                     s += sizeof(double);
3415                     sv = NEWSV(48, 0);
3416                     sv_setnv(sv, (double)adouble);
3417                     PUSHs(sv_2mortal(sv));
3418                 }
3419             }
3420             break;
3421         case 'u':
3422             along = (strend - s) * 3 / 4;
3423             sv = NEWSV(42, along);
3424             if (along)
3425                 SvPOK_on(sv);
3426             while (s < strend && *s > ' ' && *s < 'a') {
3427                 I32 a, b, c, d;
3428                 char hunk[4];
3429
3430                 hunk[3] = '\0';
3431                 len = (*s++ - ' ') & 077;
3432                 while (len > 0) {
3433                     if (s < strend && *s >= ' ')
3434                         a = (*s++ - ' ') & 077;
3435                     else
3436                         a = 0;
3437                     if (s < strend && *s >= ' ')
3438                         b = (*s++ - ' ') & 077;
3439                     else
3440                         b = 0;
3441                     if (s < strend && *s >= ' ')
3442                         c = (*s++ - ' ') & 077;
3443                     else
3444                         c = 0;
3445                     if (s < strend && *s >= ' ')
3446                         d = (*s++ - ' ') & 077;
3447                     else
3448                         d = 0;
3449                     hunk[0] = (a << 2) | (b >> 4);
3450                     hunk[1] = (b << 4) | (c >> 2);
3451                     hunk[2] = (c << 6) | d;
3452                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3453                     len -= 3;
3454                 }
3455                 if (*s == '\n')
3456                     s++;
3457                 else if (s[1] == '\n')          /* possible checksum byte */
3458                     s += 2;
3459             }
3460             XPUSHs(sv_2mortal(sv));
3461             break;
3462         }
3463         if (checksum) {
3464             sv = NEWSV(42, 0);
3465             if (strchr("fFdD", datumtype) ||
3466               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3467                 double trouble;
3468
3469                 adouble = 1.0;
3470                 while (checksum >= 16) {
3471                     checksum -= 16;
3472                     adouble *= 65536.0;
3473                 }
3474                 while (checksum >= 4) {
3475                     checksum -= 4;
3476                     adouble *= 16.0;
3477                 }
3478                 while (checksum--)
3479                     adouble *= 2.0;
3480                 along = (1 << checksum) - 1;
3481                 while (cdouble < 0.0)
3482                     cdouble += adouble;
3483                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3484                 sv_setnv(sv, cdouble);
3485             }
3486             else {
3487                 if (checksum < 32) {
3488                     aulong = (1 << checksum) - 1;
3489                     culong &= aulong;
3490                 }
3491                 sv_setuv(sv, (UV)culong);
3492             }
3493             XPUSHs(sv_2mortal(sv));
3494             checksum = 0;
3495         }
3496     }
3497     if (sp == oldsp && gimme == G_SCALAR)
3498         PUSHs(&sv_undef);
3499     RETURN;
3500 }
3501
3502 static void
3503 doencodes(register SV *sv, register char *s, register I32 len)
3504 {
3505     char hunk[5];
3506
3507     *hunk = len + ' ';
3508     sv_catpvn(sv, hunk, 1);
3509     hunk[4] = '\0';
3510     while (len > 0) {
3511         hunk[0] = ' ' + (077 & (*s >> 2));
3512         hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3513         hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3514         hunk[3] = ' ' + (077 & (s[2] & 077));
3515         sv_catpvn(sv, hunk, 4);
3516         s += 3;
3517         len -= 3;
3518     }
3519     for (s = SvPVX(sv); *s; s++) {
3520         if (*s == ' ')
3521             *s = '`';
3522     }
3523     sv_catpvn(sv, "\n", 1);
3524 }
3525
3526 static SV      *
3527 is_an_int(char *s, STRLEN l)
3528 {
3529   SV             *result = newSVpv("", l);
3530   char           *result_c = SvPV(result, na);  /* convenience */
3531   char           *out = result_c;
3532   bool            skip = 1;
3533   bool            ignore = 0;
3534
3535   while (*s) {
3536     switch (*s) {
3537     case ' ':
3538       break;
3539     case '+':
3540       if (!skip) {
3541         SvREFCNT_dec(result);
3542         return (NULL);
3543       }
3544       break;
3545     case '0':
3546     case '1':
3547     case '2':
3548     case '3':
3549     case '4':
3550     case '5':
3551     case '6':
3552     case '7':
3553     case '8':
3554     case '9':
3555       skip = 0;
3556       if (!ignore) {
3557         *(out++) = *s;
3558       }
3559       break;
3560     case '.':
3561       ignore = 1;
3562       break;
3563     default:
3564       SvREFCNT_dec(result);
3565       return (NULL);
3566     }
3567     s++;
3568   }
3569   *(out++) = '\0';
3570   SvCUR_set(result, out - result_c);
3571   return (result);
3572 }
3573
3574 static int
3575 div128(SV *pnum, bool *done)
3576                                             /* must be '\0' terminated */
3577
3578 {
3579   STRLEN          len;
3580   char           *s = SvPV(pnum, len);
3581   int             m = 0;
3582   int             r = 0;
3583   char           *t = s;
3584
3585   *done = 1;
3586   while (*t) {
3587     int             i;
3588
3589     i = m * 10 + (*t - '0');
3590     m = i & 0x7F;
3591     r = (i >> 7);               /* r < 10 */
3592     if (r) {
3593       *done = 0;
3594     }
3595     *(t++) = '0' + r;
3596   }
3597   *(t++) = '\0';
3598   SvCUR_set(pnum, (STRLEN) (t - s));
3599   return (m);
3600 }
3601
3602
3603 PP(pp_pack)
3604 {
3605     djSP; dMARK; dORIGMARK; dTARGET;
3606     register SV *cat = TARG;
3607     register I32 items;
3608     STRLEN fromlen;
3609     register char *pat = SvPVx(*++MARK, fromlen);
3610     register char *patend = pat + fromlen;
3611     register I32 len;
3612     I32 datumtype;
3613     SV *fromstr;
3614     /*SUPPRESS 442*/
3615     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3616     static char *space10 = "          ";
3617
3618     /* These must not be in registers: */
3619     char achar;
3620     I16 ashort;
3621     int aint;
3622     unsigned int auint;
3623     I32 along;
3624     U32 aulong;
3625 #ifdef HAS_QUAD
3626     Quad_t aquad;
3627     unsigned Quad_t auquad;
3628 #endif
3629     char *aptr;
3630     float afloat;
3631     double adouble;
3632     int commas = 0;
3633
3634     items = SP - MARK;
3635     MARK++;
3636     sv_setpvn(cat, "", 0);
3637     while (pat < patend) {
3638 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3639         datumtype = *pat++ & 0xFF;
3640         if (isSPACE(datumtype))
3641             continue;
3642         if (*pat == '*') {
3643             len = strchr("@Xxu", datumtype) ? 0 : items;
3644             pat++;
3645         }
3646         else if (isDIGIT(*pat)) {
3647             len = *pat++ - '0';
3648             while (isDIGIT(*pat))
3649                 len = (len * 10) + (*pat++ - '0');
3650         }
3651         else
3652             len = 1;
3653         switch(datumtype) {
3654         default:
3655             croak("Invalid type in pack: '%c'", (int)datumtype);
3656         case ',': /* grandfather in commas but with a warning */
3657             if (commas++ == 0 && dowarn)
3658                 warn("Invalid type in pack: '%c'", (int)datumtype);
3659             break;
3660         case '%':
3661             DIE("%% may only be used in unpack");
3662         case '@':
3663             len -= SvCUR(cat);
3664             if (len > 0)
3665                 goto grow;
3666             len = -len;
3667             if (len > 0)
3668                 goto shrink;
3669             break;
3670         case 'X':
3671           shrink:
3672             if (SvCUR(cat) < len)
3673                 DIE("X outside of string");
3674             SvCUR(cat) -= len;
3675             *SvEND(cat) = '\0';
3676             break;
3677         case 'x':
3678           grow:
3679             while (len >= 10) {
3680                 sv_catpvn(cat, null10, 10);
3681                 len -= 10;
3682             }
3683             sv_catpvn(cat, null10, len);
3684             break;
3685         case 'A':
3686         case 'a':
3687             fromstr = NEXTFROM;
3688             aptr = SvPV(fromstr, fromlen);
3689             if (pat[-1] == '*')
3690                 len = fromlen;
3691             if (fromlen > len)
3692                 sv_catpvn(cat, aptr, len);
3693             else {
3694                 sv_catpvn(cat, aptr, fromlen);
3695                 len -= fromlen;
3696                 if (datumtype == 'A') {
3697                     while (len >= 10) {
3698                         sv_catpvn(cat, space10, 10);
3699                         len -= 10;
3700                     }
3701                     sv_catpvn(cat, space10, len);
3702                 }
3703                 else {
3704                     while (len >= 10) {
3705                         sv_catpvn(cat, null10, 10);
3706                         len -= 10;
3707                     }
3708                     sv_catpvn(cat, null10, len);
3709                 }
3710             }
3711             break;
3712         case 'B':
3713         case 'b':
3714             {
3715                 char *savepat = pat;
3716                 I32 saveitems;
3717
3718                 fromstr = NEXTFROM;
3719                 saveitems = items;
3720                 aptr = SvPV(fromstr, fromlen);
3721                 if (pat[-1] == '*')
3722                     len = fromlen;
3723                 pat = aptr;
3724                 aint = SvCUR(cat);
3725                 SvCUR(cat) += (len+7)/8;
3726                 SvGROW(cat, SvCUR(cat) + 1);
3727                 aptr = SvPVX(cat) + aint;
3728                 if (len > fromlen)
3729                     len = fromlen;
3730                 aint = len;
3731                 items = 0;
3732                 if (datumtype == 'B') {
3733                     for (len = 0; len++ < aint;) {
3734                         items |= *pat++ & 1;
3735                         if (len & 7)
3736                             items <<= 1;
3737                         else {
3738                             *aptr++ = items & 0xff;
3739                             items = 0;
3740                         }
3741                     }
3742                 }
3743                 else {
3744                     for (len = 0; len++ < aint;) {
3745                         if (*pat++ & 1)
3746                             items |= 128;
3747                         if (len & 7)
3748                             items >>= 1;
3749                         else {
3750                             *aptr++ = items & 0xff;
3751                             items = 0;
3752                         }
3753                     }
3754                 }
3755                 if (aint & 7) {
3756                     if (datumtype == 'B')
3757                         items <<= 7 - (aint & 7);
3758                     else
3759                         items >>= 7 - (aint & 7);
3760                     *aptr++ = items & 0xff;
3761                 }
3762                 pat = SvPVX(cat) + SvCUR(cat);
3763                 while (aptr <= pat)
3764                     *aptr++ = '\0';
3765
3766                 pat = savepat;
3767                 items = saveitems;
3768             }
3769             break;
3770         case 'H':
3771         case 'h':
3772             {
3773                 char *savepat = pat;
3774                 I32 saveitems;
3775
3776                 fromstr = NEXTFROM;
3777                 saveitems = items;
3778                 aptr = SvPV(fromstr, fromlen);
3779                 if (pat[-1] == '*')
3780                     len = fromlen;
3781                 pat = aptr;
3782                 aint = SvCUR(cat);
3783                 SvCUR(cat) += (len+1)/2;
3784                 SvGROW(cat, SvCUR(cat) + 1);
3785                 aptr = SvPVX(cat) + aint;
3786                 if (len > fromlen)
3787                     len = fromlen;
3788                 aint = len;
3789                 items = 0;
3790                 if (datumtype == 'H') {
3791                     for (len = 0; len++ < aint;) {
3792                         if (isALPHA(*pat))
3793                             items |= ((*pat++ & 15) + 9) & 15;
3794                         else
3795                             items |= *pat++ & 15;
3796                         if (len & 1)
3797                             items <<= 4;
3798                         else {
3799                             *aptr++ = items & 0xff;
3800                             items = 0;
3801                         }
3802                     }
3803                 }
3804                 else {
3805                     for (len = 0; len++ < aint;) {
3806                         if (isALPHA(*pat))
3807                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3808                         else
3809                             items |= (*pat++ & 15) << 4;
3810                         if (len & 1)
3811                             items >>= 4;
3812                         else {
3813                             *aptr++ = items & 0xff;
3814                             items = 0;
3815                         }
3816                     }
3817                 }
3818                 if (aint & 1)
3819                     *aptr++ = items & 0xff;
3820                 pat = SvPVX(cat) + SvCUR(cat);
3821                 while (aptr <= pat)
3822                     *aptr++ = '\0';
3823
3824                 pat = savepat;
3825                 items = saveitems;
3826             }
3827             break;
3828         case 'C':
3829         case 'c':
3830             while (len-- > 0) {
3831                 fromstr = NEXTFROM;
3832                 aint = SvIV(fromstr);
3833                 achar = aint;
3834                 sv_catpvn(cat, &achar, sizeof(char));
3835             }
3836             break;
3837         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3838         case 'f':
3839         case 'F':
3840             while (len-- > 0) {
3841                 fromstr = NEXTFROM;
3842                 afloat = (float)SvNV(fromstr);
3843                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3844             }
3845             break;
3846         case 'd':
3847         case 'D':
3848             while (len-- > 0) {
3849                 fromstr = NEXTFROM;
3850                 adouble = (double)SvNV(fromstr);
3851                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3852             }
3853             break;
3854         case 'n':
3855             while (len-- > 0) {
3856                 fromstr = NEXTFROM;
3857                 ashort = (I16)SvIV(fromstr);
3858 #ifdef HAS_HTONS
3859                 ashort = PerlSock_htons(ashort);
3860 #endif
3861                 CAT16(cat, &ashort);
3862             }
3863             break;
3864         case 'v':
3865             while (len-- > 0) {
3866                 fromstr = NEXTFROM;
3867                 ashort = (I16)SvIV(fromstr);
3868 #ifdef HAS_HTOVS
3869                 ashort = htovs(ashort);
3870 #endif
3871                 CAT16(cat, &ashort);
3872             }
3873             break;
3874         case 'S':
3875         case 's':
3876             while (len-- > 0) {
3877                 fromstr = NEXTFROM;
3878                 ashort = (I16)SvIV(fromstr);
3879                 CAT16(cat, &ashort);
3880             }
3881             break;
3882         case 'I':
3883             while (len-- > 0) {
3884                 fromstr = NEXTFROM;
3885                 auint = SvUV(fromstr);
3886                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3887             }
3888             break;
3889         case 'w':
3890             while (len-- > 0) {
3891                 fromstr = NEXTFROM;
3892                 adouble = floor(SvNV(fromstr));
3893
3894                 if (adouble < 0)
3895                     croak("Cannot compress negative numbers");
3896
3897                 if (
3898 #ifdef BW_BITS
3899                     adouble <= BW_MASK
3900 #else
3901 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
3902                     adouble <= UV_MAX_cxux
3903 #else
3904                     adouble <= UV_MAX
3905 #endif
3906 #endif
3907                     )
3908                 {
3909                     char   buf[1 + sizeof(UV)];
3910                     char  *in = buf + sizeof(buf);
3911                     UV     auv = U_V(adouble);;
3912
3913                     do {
3914                         *--in = (auv & 0x7f) | 0x80;
3915                         auv >>= 7;
3916                     } while (auv);
3917                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3918                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3919                 }
3920                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
3921                     char           *from, *result, *in;
3922                     SV             *norm;
3923                     STRLEN          len;
3924                     bool            done;
3925
3926                     /* Copy string and check for compliance */
3927                     from = SvPV(fromstr, len);
3928                     if ((norm = is_an_int(from, len)) == NULL)
3929                         croak("can compress only unsigned integer");
3930
3931                     New('w', result, len, char);
3932                     in = result + len;
3933                     done = FALSE;
3934                     while (!done)
3935                         *--in = div128(norm, &done) | 0x80;
3936                     result[len - 1] &= 0x7F; /* clear continue bit */
3937                     sv_catpvn(cat, in, (result + len) - in);
3938                     Safefree(result);
3939                     SvREFCNT_dec(norm); /* free norm */
3940                 }
3941                 else if (SvNOKp(fromstr)) {
3942                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
3943                     char  *in = buf + sizeof(buf);
3944
3945                     do {
3946                         double next = floor(adouble / 128);
3947                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
3948                         if (--in < buf)  /* this cannot happen ;-) */
3949                             croak ("Cannot compress integer");
3950                         adouble = next;
3951                     } while (adouble > 0);
3952                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3953                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3954                 }
3955                 else
3956                     croak("Cannot compress non integer");
3957             }
3958             break;
3959         case 'i':
3960             while (len-- > 0) {
3961                 fromstr = NEXTFROM;
3962                 aint = SvIV(fromstr);
3963                 sv_catpvn(cat, (char*)&aint, sizeof(int));
3964             }
3965             break;
3966         case 'N':
3967             while (len-- > 0) {
3968                 fromstr = NEXTFROM;
3969                 aulong = SvUV(fromstr);
3970 #ifdef HAS_HTONL
3971                 aulong = PerlSock_htonl(aulong);
3972 #endif
3973                 CAT32(cat, &aulong);
3974             }
3975             break;
3976         case 'V':
3977             while (len-- > 0) {
3978                 fromstr = NEXTFROM;
3979                 aulong = SvUV(fromstr);
3980 #ifdef HAS_HTOVL
3981                 aulong = htovl(aulong);
3982 #endif
3983                 CAT32(cat, &aulong);
3984             }
3985             break;
3986         case 'L':
3987             while (len-- > 0) {
3988                 fromstr = NEXTFROM;
3989                 aulong = SvUV(fromstr);
3990                 CAT32(cat, &aulong);
3991             }
3992             break;
3993         case 'l':
3994             while (len-- > 0) {
3995                 fromstr = NEXTFROM;
3996                 along = SvIV(fromstr);
3997                 CAT32(cat, &along);
3998             }
3999             break;
4000 #ifdef HAS_QUAD
4001         case 'Q':
4002             while (len-- > 0) {
4003                 fromstr = NEXTFROM;
4004                 auquad = (unsigned Quad_t)SvIV(fromstr);
4005                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4006             }
4007             break;
4008         case 'q':
4009             while (len-- > 0) {
4010                 fromstr = NEXTFROM;
4011                 aquad = (Quad_t)SvIV(fromstr);
4012                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4013             }
4014             break;
4015 #endif /* HAS_QUAD */
4016         case 'P':
4017             len = 1;            /* assume SV is correct length */
4018             /* FALL THROUGH */
4019         case 'p':
4020             while (len-- > 0) {
4021                 fromstr = NEXTFROM;
4022                 if (fromstr == &sv_undef)
4023                     aptr = NULL;
4024                 else {
4025                     /* XXX better yet, could spirit away the string to
4026                      * a safe spot and hang on to it until the result
4027                      * of pack() (and all copies of the result) are
4028                      * gone.
4029                      */
4030                     if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4031                         warn("Attempt to pack pointer to temporary value");
4032                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4033                         aptr = SvPV(fromstr,na);
4034                     else
4035                         aptr = SvPV_force(fromstr,na);
4036                 }
4037                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4038             }
4039             break;
4040         case 'u':
4041             fromstr = NEXTFROM;
4042             aptr = SvPV(fromstr, fromlen);
4043             SvGROW(cat, fromlen * 4 / 3);
4044             if (len <= 1)
4045                 len = 45;
4046             else
4047                 len = len / 3 * 3;
4048             while (fromlen > 0) {
4049                 I32 todo;
4050
4051                 if (fromlen > len)
4052                     todo = len;
4053                 else
4054                     todo = fromlen;
4055                 doencodes(cat, aptr, todo);
4056                 fromlen -= todo;
4057                 aptr += todo;
4058             }
4059             break;
4060         }
4061     }
4062     SvSETMAGIC(cat);
4063     SP = ORIGMARK;
4064     PUSHs(cat);
4065     RETURN;
4066 }
4067 #undef NEXTFROM
4068
4069
4070 PP(pp_split)
4071 {
4072     djSP; dTARG;
4073     AV *ary;
4074     register I32 limit = POPi;                  /* note, negative is forever */
4075     SV *sv = POPs;
4076     STRLEN len;
4077     register char *s = SvPV(sv, len);
4078     char *strend = s + len;
4079     register PMOP *pm;
4080     register REGEXP *rx;
4081     register SV *dstr;
4082     register char *m;
4083     I32 iters = 0;
4084     I32 maxiters = (strend - s) + 10;
4085     I32 i;
4086     char *orig;
4087     I32 origlimit = limit;
4088     I32 realarray = 0;
4089     I32 base;
4090     AV *oldstack = curstack;
4091     I32 gimme = GIMME_V;
4092     I32 oldsave = savestack_ix;
4093     I32 make_mortal = 1;
4094     MAGIC *mg = (MAGIC *) NULL;
4095
4096 #ifdef DEBUGGING
4097     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4098 #else
4099     pm = (PMOP*)POPs;
4100 #endif
4101     if (!pm || !s)
4102         DIE("panic: do_split");
4103     rx = pm->op_pmregexp;
4104
4105     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4106              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4107
4108     if (pm->op_pmreplroot)
4109         ary = GvAVn((GV*)pm->op_pmreplroot);
4110     else if (gimme != G_ARRAY)
4111 #ifdef USE_THREADS
4112         ary = (AV*)curpad[0];
4113 #else
4114         ary = GvAVn(defgv);
4115 #endif /* USE_THREADS */
4116     else
4117         ary = Nullav;
4118     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4119         realarray = 1;
4120         PUTBACK;
4121         av_extend(ary,0);
4122         av_clear(ary);
4123         SPAGAIN;
4124         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4125             PUSHMARK(SP);
4126             XPUSHs(mg->mg_obj);
4127         }
4128         else {
4129             if (!AvREAL(ary)) {
4130                 AvREAL_on(ary);
4131                 for (i = AvFILLp(ary); i >= 0; i--)
4132                     AvARRAY(ary)[i] = &sv_undef;        /* don't free mere refs */
4133             }
4134             /* temporarily switch stacks */
4135             SWITCHSTACK(curstack, ary);
4136             make_mortal = 0;
4137         }
4138     }
4139     base = SP - stack_base;
4140     orig = s;
4141     if (pm->op_pmflags & PMf_SKIPWHITE) {
4142         if (pm->op_pmflags & PMf_LOCALE) {
4143             while (isSPACE_LC(*s))
4144                 s++;
4145         }
4146         else {
4147             while (isSPACE(*s))
4148                 s++;
4149         }
4150     }
4151     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4152         SAVEINT(multiline);
4153         multiline = pm->op_pmflags & PMf_MULTILINE;
4154     }
4155
4156     if (!limit)
4157         limit = maxiters + 2;
4158     if (pm->op_pmflags & PMf_WHITE) {
4159         while (--limit) {
4160             m = s;
4161             while (m < strend &&
4162                    !((pm->op_pmflags & PMf_LOCALE)
4163                      ? isSPACE_LC(*m) : isSPACE(*m)))
4164                 ++m;
4165             if (m >= strend)
4166                 break;
4167
4168             dstr = NEWSV(30, m-s);
4169             sv_setpvn(dstr, s, m-s);
4170             if (make_mortal)
4171                 sv_2mortal(dstr);
4172             XPUSHs(dstr);
4173
4174             s = m + 1;
4175             while (s < strend &&
4176                    ((pm->op_pmflags & PMf_LOCALE)
4177                     ? isSPACE_LC(*s) : isSPACE(*s)))
4178                 ++s;
4179         }
4180     }
4181     else if (strEQ("^", rx->precomp)) {
4182         while (--limit) {
4183             /*SUPPRESS 530*/
4184             for (m = s; m < strend && *m != '\n'; m++) ;
4185             m++;
4186             if (m >= strend)
4187                 break;
4188             dstr = NEWSV(30, m-s);
4189             sv_setpvn(dstr, s, m-s);
4190             if (make_mortal)
4191                 sv_2mortal(dstr);
4192             XPUSHs(dstr);
4193             s = m;
4194         }
4195     }
4196     else if (rx->check_substr && !rx->nparens
4197              && (rx->reganch & ROPT_CHECK_ALL)
4198              && !(rx->reganch & ROPT_ANCH)) {
4199         i = SvCUR(rx->check_substr);
4200         if (i == 1 && !SvTAIL(rx->check_substr)) {
4201             i = *SvPVX(rx->check_substr);
4202             while (--limit) {
4203                 /*SUPPRESS 530*/
4204                 for (m = s; m < strend && *m != i; m++) ;
4205                 if (m >= strend)
4206                     break;
4207                 dstr = NEWSV(30, m-s);
4208                 sv_setpvn(dstr, s, m-s);
4209                 if (make_mortal)
4210                     sv_2mortal(dstr);
4211                 XPUSHs(dstr);
4212                 s = m + 1;
4213             }
4214         }
4215         else {
4216 #ifndef lint
4217             while (s < strend && --limit &&
4218               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4219                     rx->check_substr)) )
4220 #endif
4221             {
4222                 dstr = NEWSV(31, m-s);
4223                 sv_setpvn(dstr, s, m-s);
4224                 if (make_mortal)
4225                     sv_2mortal(dstr);
4226                 XPUSHs(dstr);
4227                 s = m + i;
4228             }
4229         }
4230     }
4231     else {
4232         maxiters += (strend - s) * rx->nparens;
4233         while (s < strend && --limit &&
4234                regexec_flags(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4235         {
4236             TAINT_IF(RX_MATCH_TAINTED(rx));
4237             if (rx->subbase
4238               && rx->subbase != orig) {
4239                 m = s;
4240                 s = orig;
4241                 orig = rx->subbase;
4242                 s = orig + (m - s);
4243                 strend = s + (strend - m);
4244             }
4245             m = rx->startp[0];
4246             dstr = NEWSV(32, m-s);
4247             sv_setpvn(dstr, s, m-s);
4248             if (make_mortal)
4249                 sv_2mortal(dstr);
4250             XPUSHs(dstr);
4251             if (rx->nparens) {
4252                 for (i = 1; i <= rx->nparens; i++) {
4253                     s = rx->startp[i];
4254                     m = rx->endp[i];
4255                     if (m && s) {
4256                         dstr = NEWSV(33, m-s);
4257                         sv_setpvn(dstr, s, m-s);
4258                     }
4259                     else
4260                         dstr = NEWSV(33, 0);
4261                     if (make_mortal)
4262                         sv_2mortal(dstr);
4263                     XPUSHs(dstr);
4264                 }
4265             }
4266             s = rx->endp[0];
4267         }
4268     }
4269
4270     LEAVE_SCOPE(oldsave);
4271     iters = (SP - stack_base) - base;
4272     if (iters > maxiters)
4273         DIE("Split loop");
4274
4275     /* keep field after final delim? */
4276     if (s < strend || (iters && origlimit)) {
4277         dstr = NEWSV(34, strend-s);
4278         sv_setpvn(dstr, s, strend-s);
4279         if (make_mortal)
4280             sv_2mortal(dstr);
4281         XPUSHs(dstr);
4282         iters++;
4283     }
4284     else if (!origlimit) {
4285         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4286             iters--, SP--;
4287     }
4288
4289     if (realarray) {
4290         if (!mg) {
4291             SWITCHSTACK(ary, oldstack);
4292             if (SvSMAGICAL(ary)) {
4293                 PUTBACK;
4294                 mg_set((SV*)ary);
4295                 SPAGAIN;
4296             }
4297             if (gimme == G_ARRAY) {
4298                 EXTEND(SP, iters);
4299                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4300                 SP += iters;
4301                 RETURN;
4302             }
4303         }
4304         else {
4305             PUTBACK;
4306             ENTER;
4307             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4308             LEAVE;
4309             SPAGAIN;
4310             if (gimme == G_ARRAY) {
4311                 /* EXTEND should not be needed - we just popped them */
4312                 EXTEND(SP, iters);
4313                 for (i=0; i < iters; i++) {
4314                     SV **svp = av_fetch(ary, i, FALSE);
4315                     PUSHs((svp) ? *svp : &sv_undef);
4316                 }
4317                 RETURN;
4318             }
4319         }
4320     }
4321     else {
4322         if (gimme == G_ARRAY)
4323             RETURN;
4324     }
4325     if (iters || !pm->op_pmreplroot) {
4326         GETTARGET;
4327         PUSHi(iters);
4328         RETURN;
4329     }
4330     RETPUSHUNDEF;
4331 }
4332
4333 #ifdef USE_THREADS
4334 void
4335 unlock_condpair(void *svv)
4336 {
4337     dTHR;
4338     MAGIC *mg = mg_find((SV*)svv, 'm');
4339
4340     if (!mg)
4341         croak("panic: unlock_condpair unlocking non-mutex");
4342     MUTEX_LOCK(MgMUTEXP(mg));
4343     if (MgOWNER(mg) != thr)
4344         croak("panic: unlock_condpair unlocking mutex that we don't own");
4345     MgOWNER(mg) = 0;
4346     COND_SIGNAL(MgOWNERCONDP(mg));
4347     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4348                           (unsigned long)thr, (unsigned long)svv);)
4349     MUTEX_UNLOCK(MgMUTEXP(mg));
4350 }
4351 #endif /* USE_THREADS */
4352
4353 PP(pp_lock)
4354 {
4355     djSP;
4356     dTOPss;
4357     SV *retsv = sv;
4358 #ifdef USE_THREADS
4359     MAGIC *mg;
4360
4361     if (SvROK(sv))
4362         sv = SvRV(sv);
4363
4364     mg = condpair_magic(sv);
4365     MUTEX_LOCK(MgMUTEXP(mg));
4366     if (MgOWNER(mg) == thr)
4367         MUTEX_UNLOCK(MgMUTEXP(mg));
4368     else {
4369         while (MgOWNER(mg))
4370             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4371         MgOWNER(mg) = thr;
4372         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4373                               (unsigned long)thr, (unsigned long)sv);)
4374         MUTEX_UNLOCK(MgMUTEXP(mg));
4375         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4376         save_destructor(unlock_condpair, sv);
4377     }
4378 #endif /* USE_THREADS */
4379     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4380         || SvTYPE(retsv) == SVt_PVCV) {
4381         retsv = refto(retsv);
4382     }
4383     SETs(retsv);
4384     RETURN;
4385 }
4386
4387 PP(pp_threadsv)
4388 {
4389     djSP;
4390 #ifdef USE_THREADS
4391     EXTEND(sp, 1);
4392     if (op->op_private & OPpLVAL_INTRO)
4393         PUSHs(*save_threadsv(op->op_targ));
4394     else
4395         PUSHs(THREADSV(op->op_targ));
4396     RETURN;
4397 #else
4398     DIE("tried to access per-thread data in non-threaded perl");
4399 #endif /* USE_THREADS */
4400 }