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