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