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 PP(pp_rand)
1554 {
1555     djSP; dTARGET;
1556     double value;
1557     if (MAXARG < 1)
1558         value = 1.0;
1559     else
1560         value = POPn;
1561     if (value == 0.0)
1562         value = 1.0;
1563     if (!srand_called) {
1564         (void)srand((unsigned)seed());
1565         srand_called = TRUE;
1566     }
1567 #if RANDBITS == 31
1568     value = rand() * value / 2147483648.0;
1569 #else
1570 #if RANDBITS == 16
1571     value = rand() * value / 65536.0;
1572 #else
1573 #if RANDBITS == 15
1574     value = rand() * value / 32768.0;
1575 #else
1576     value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1577 #endif
1578 #endif
1579 #endif
1580     XPUSHn(value);
1581     RETURN;
1582 }
1583
1584 PP(pp_srand)
1585 {
1586     djSP;
1587     UV anum;
1588     if (MAXARG < 1)
1589         anum = seed();
1590     else
1591         anum = POPu;
1592     (void)srand((unsigned)anum);
1593     srand_called = TRUE;
1594     EXTEND(SP, 1);
1595     RETPUSHYES;
1596 }
1597
1598 STATIC U32
1599 seed(void)
1600 {
1601     /*
1602      * This is really just a quick hack which grabs various garbage
1603      * values.  It really should be a real hash algorithm which
1604      * spreads the effect of every input bit onto every output bit,
1605      * if someone who knows about such tings would bother to write it.
1606      * Might be a good idea to add that function to CORE as well.
1607      * No numbers below come from careful analysis or anyting here,
1608      * except they are primes and SEED_C1 > 1E6 to get a full-width
1609      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1610      * probably be bigger too.
1611      */
1612 #if RANDBITS > 16
1613 #  define SEED_C1       1000003
1614 #define   SEED_C4       73819
1615 #else
1616 #  define SEED_C1       25747
1617 #define   SEED_C4       20639
1618 #endif
1619 #define   SEED_C2       3
1620 #define   SEED_C3       269
1621 #define   SEED_C5       26107
1622
1623     dTHR;
1624     U32 u;
1625 #ifdef VMS
1626 #  include <starlet.h>
1627     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1628      * in 100-ns units, typically incremented ever 10 ms.        */
1629     unsigned int when[2];
1630     _ckvmssts(sys$gettim(when));
1631     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1632 #else
1633 #  ifdef HAS_GETTIMEOFDAY
1634     struct timeval when;
1635     gettimeofday(&when,(struct timezone *) 0);
1636     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1637 #  else
1638     Time_t when;
1639     (void)time(&when);
1640     u = (U32)SEED_C1 * when;
1641 #  endif
1642 #endif
1643     u += SEED_C3 * (U32)getpid();
1644     u += SEED_C4 * (U32)(UV)stack_sp;
1645 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1646     u += SEED_C5 * (U32)(UV)&when;
1647 #endif
1648     return u;
1649 }
1650
1651 PP(pp_exp)
1652 {
1653     djSP; dTARGET; tryAMAGICun(exp);
1654     {
1655       double value;
1656       value = POPn;
1657       value = exp(value);
1658       XPUSHn(value);
1659       RETURN;
1660     }
1661 }
1662
1663 PP(pp_log)
1664 {
1665     djSP; dTARGET; tryAMAGICun(log);
1666     {
1667       double value;
1668       value = POPn;
1669       if (value <= 0.0) {
1670         SET_NUMERIC_STANDARD();
1671         DIE("Can't take log of %g", value);
1672       }
1673       value = log(value);
1674       XPUSHn(value);
1675       RETURN;
1676     }
1677 }
1678
1679 PP(pp_sqrt)
1680 {
1681     djSP; dTARGET; tryAMAGICun(sqrt);
1682     {
1683       double value;
1684       value = POPn;
1685       if (value < 0.0) {
1686         SET_NUMERIC_STANDARD();
1687         DIE("Can't take sqrt of %g", value);
1688       }
1689       value = sqrt(value);
1690       XPUSHn(value);
1691       RETURN;
1692     }
1693 }
1694
1695 PP(pp_int)
1696 {
1697     djSP; dTARGET;
1698     {
1699       double value = TOPn;
1700       IV iv;
1701
1702       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1703         iv = SvIVX(TOPs);
1704         SETi(iv);
1705       }
1706       else {
1707         if (value >= 0.0)
1708           (void)modf(value, &value);
1709         else {
1710           (void)modf(-value, &value);
1711           value = -value;
1712         }
1713         iv = I_V(value);
1714         if (iv == value)
1715           SETi(iv);
1716         else
1717           SETn(value);
1718       }
1719     }
1720     RETURN;
1721 }
1722
1723 PP(pp_abs)
1724 {
1725     djSP; dTARGET; tryAMAGICun(abs);
1726     {
1727       double value = TOPn;
1728       IV iv;
1729
1730       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1731           (iv = SvIVX(TOPs)) != IV_MIN) {
1732         if (iv < 0)
1733           iv = -iv;
1734         SETi(iv);
1735       }
1736       else {
1737         if (value < 0.0)
1738             value = -value;
1739         SETn(value);
1740       }
1741     }
1742     RETURN;
1743 }
1744
1745 PP(pp_hex)
1746 {
1747     djSP; dTARGET;
1748     char *tmps;
1749     I32 argtype;
1750
1751     tmps = POPp;
1752     XPUSHu(scan_hex(tmps, 99, &argtype));
1753     RETURN;
1754 }
1755
1756 PP(pp_oct)
1757 {
1758     djSP; dTARGET;
1759     UV value;
1760     I32 argtype;
1761     char *tmps;
1762
1763     tmps = POPp;
1764     while (*tmps && isSPACE(*tmps))
1765         tmps++;
1766     if (*tmps == '0')
1767         tmps++;
1768     if (*tmps == 'x')
1769         value = scan_hex(++tmps, 99, &argtype);
1770     else
1771         value = scan_oct(tmps, 99, &argtype);
1772     XPUSHu(value);
1773     RETURN;
1774 }
1775
1776 /* String stuff. */
1777
1778 PP(pp_length)
1779 {
1780     djSP; dTARGET;
1781     SETi( sv_len(TOPs) );
1782     RETURN;
1783 }
1784
1785 PP(pp_substr)
1786 {
1787     djSP; dTARGET;
1788     SV *sv;
1789     I32 len;
1790     STRLEN curlen;
1791     I32 pos;
1792     I32 rem;
1793     I32 fail;
1794     I32 lvalue = op->op_flags & OPf_MOD;
1795     char *tmps;
1796     I32 arybase = curcop->cop_arybase;
1797     char *repl = 0;
1798     STRLEN repl_len;
1799
1800     SvTAINTED_off(TARG);                        /* decontaminate */
1801     if (MAXARG > 2) {
1802         if (MAXARG > 3) {
1803             sv = POPs;
1804             repl = SvPV(sv, repl_len);
1805         }
1806         len = POPi;
1807     }
1808     pos = POPi;
1809     sv = POPs;
1810     PUTBACK;
1811     tmps = SvPV(sv, curlen);
1812     if (pos >= arybase) {
1813         pos -= arybase;
1814         rem = curlen-pos;
1815         fail = rem;
1816         if (MAXARG > 2) {
1817             if (len < 0) {
1818                 rem += len;
1819                 if (rem < 0)
1820                     rem = 0;
1821             }
1822             else if (rem > len)
1823                      rem = len;
1824         }
1825     }
1826     else {
1827         pos += curlen;
1828         if (MAXARG < 3)
1829             rem = curlen;
1830         else if (len >= 0) {
1831             rem = pos+len;
1832             if (rem > (I32)curlen)
1833                 rem = curlen;
1834         }
1835         else {
1836             rem = curlen+len;
1837             if (rem < pos)
1838                 rem = pos;
1839         }
1840         if (pos < 0)
1841             pos = 0;
1842         fail = rem;
1843         rem -= pos;
1844     }
1845     if (fail < 0) {
1846         if (dowarn || lvalue || repl)
1847             warn("substr outside of string");
1848         RETPUSHUNDEF;
1849     }
1850     else {
1851         tmps += pos;
1852         sv_setpvn(TARG, tmps, rem);
1853         if (lvalue) {                   /* it's an lvalue! */
1854             if (!SvGMAGICAL(sv)) {
1855                 if (SvROK(sv)) {
1856                     SvPV_force(sv,na);
1857                     if (dowarn)
1858                         warn("Attempt to use reference as lvalue in substr");
1859                 }
1860                 if (SvOK(sv))           /* is it defined ? */
1861                     (void)SvPOK_only(sv);
1862                 else
1863                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1864             }
1865
1866             if (SvTYPE(TARG) < SVt_PVLV) {
1867                 sv_upgrade(TARG, SVt_PVLV);
1868                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1869             }
1870
1871             LvTYPE(TARG) = 'x';
1872             if (LvTARG(TARG) != sv) {
1873                 if (LvTARG(TARG))
1874                     SvREFCNT_dec(LvTARG(TARG));
1875                 LvTARG(TARG) = SvREFCNT_inc(sv);
1876             }
1877             LvTARGOFF(TARG) = pos;
1878             LvTARGLEN(TARG) = rem;
1879         }
1880         else if (repl)
1881             sv_insert(sv, pos, rem, repl, repl_len);
1882     }
1883     SPAGAIN;
1884     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1885     RETURN;
1886 }
1887
1888 PP(pp_vec)
1889 {
1890     djSP; dTARGET;
1891     register I32 size = POPi;
1892     register I32 offset = POPi;
1893     register SV *src = POPs;
1894     I32 lvalue = op->op_flags & OPf_MOD;
1895     STRLEN srclen;
1896     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1897     unsigned long retnum;
1898     I32 len;
1899
1900     SvTAINTED_off(TARG);                        /* decontaminate */
1901     offset *= size;             /* turn into bit offset */
1902     len = (offset + size + 7) / 8;
1903     if (offset < 0 || size < 1)
1904         retnum = 0;
1905     else {
1906         if (lvalue) {                      /* it's an lvalue! */
1907             if (SvTYPE(TARG) < SVt_PVLV) {
1908                 sv_upgrade(TARG, SVt_PVLV);
1909                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1910             }
1911
1912             LvTYPE(TARG) = 'v';
1913             if (LvTARG(TARG) != src) {
1914                 if (LvTARG(TARG))
1915                     SvREFCNT_dec(LvTARG(TARG));
1916                 LvTARG(TARG) = SvREFCNT_inc(src);
1917             }
1918             LvTARGOFF(TARG) = offset;
1919             LvTARGLEN(TARG) = size;
1920         }
1921         if (len > srclen) {
1922             if (size <= 8)
1923                 retnum = 0;
1924             else {
1925                 offset >>= 3;
1926                 if (size == 16) {
1927                     if (offset >= srclen)
1928                         retnum = 0;
1929                     else
1930                         retnum = (unsigned long) s[offset] << 8;
1931                 }
1932                 else if (size == 32) {
1933                     if (offset >= srclen)
1934                         retnum = 0;
1935                     else if (offset + 1 >= srclen)
1936                         retnum = (unsigned long) s[offset] << 24;
1937                     else if (offset + 2 >= srclen)
1938                         retnum = ((unsigned long) s[offset] << 24) +
1939                             ((unsigned long) s[offset + 1] << 16);
1940                     else
1941                         retnum = ((unsigned long) s[offset] << 24) +
1942                             ((unsigned long) s[offset + 1] << 16) +
1943                             (s[offset + 2] << 8);
1944                 }
1945             }
1946         }
1947         else if (size < 8)
1948             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1949         else {
1950             offset >>= 3;
1951             if (size == 8)
1952                 retnum = s[offset];
1953             else if (size == 16)
1954                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1955             else if (size == 32)
1956                 retnum = ((unsigned long) s[offset] << 24) +
1957                         ((unsigned long) s[offset + 1] << 16) +
1958                         (s[offset + 2] << 8) + s[offset+3];
1959         }
1960     }
1961
1962     sv_setuv(TARG, (UV)retnum);
1963     PUSHs(TARG);
1964     RETURN;
1965 }
1966
1967 PP(pp_index)
1968 {
1969     djSP; dTARGET;
1970     SV *big;
1971     SV *little;
1972     I32 offset;
1973     I32 retval;
1974     char *tmps;
1975     char *tmps2;
1976     STRLEN biglen;
1977     I32 arybase = curcop->cop_arybase;
1978
1979     if (MAXARG < 3)
1980         offset = 0;
1981     else
1982         offset = POPi - arybase;
1983     little = POPs;
1984     big = POPs;
1985     tmps = SvPV(big, biglen);
1986     if (offset < 0)
1987         offset = 0;
1988     else if (offset > biglen)
1989         offset = biglen;
1990     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
1991       (unsigned char*)tmps + biglen, little, 0)))
1992         retval = -1 + arybase;
1993     else
1994         retval = tmps2 - tmps + arybase;
1995     PUSHi(retval);
1996     RETURN;
1997 }
1998
1999 PP(pp_rindex)
2000 {
2001     djSP; dTARGET;
2002     SV *big;
2003     SV *little;
2004     STRLEN blen;
2005     STRLEN llen;
2006     SV *offstr;
2007     I32 offset;
2008     I32 retval;
2009     char *tmps;
2010     char *tmps2;
2011     I32 arybase = curcop->cop_arybase;
2012
2013     if (MAXARG >= 3)
2014         offstr = POPs;
2015     little = POPs;
2016     big = POPs;
2017     tmps2 = SvPV(little, llen);
2018     tmps = SvPV(big, blen);
2019     if (MAXARG < 3)
2020         offset = blen;
2021     else
2022         offset = SvIV(offstr) - arybase + llen;
2023     if (offset < 0)
2024         offset = 0;
2025     else if (offset > blen)
2026         offset = blen;
2027     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2028                           tmps2, tmps2 + llen)))
2029         retval = -1 + arybase;
2030     else
2031         retval = tmps2 - tmps + arybase;
2032     PUSHi(retval);
2033     RETURN;
2034 }
2035
2036 PP(pp_sprintf)
2037 {
2038     djSP; dMARK; dORIGMARK; dTARGET;
2039 #ifdef USE_LOCALE_NUMERIC
2040     if (op->op_private & OPpLOCALE)
2041         SET_NUMERIC_LOCAL();
2042     else
2043         SET_NUMERIC_STANDARD();
2044 #endif
2045     do_sprintf(TARG, SP-MARK, MARK+1);
2046     TAINT_IF(SvTAINTED(TARG));
2047     SP = ORIGMARK;
2048     PUSHTARG;
2049     RETURN;
2050 }
2051
2052 PP(pp_ord)
2053 {
2054     djSP; dTARGET;
2055     I32 value;
2056     char *tmps;
2057
2058 #ifndef I286
2059     tmps = POPp;
2060     value = (I32) (*tmps & 255);
2061 #else
2062     I32 anum;
2063     tmps = POPp;
2064     anum = (I32) *tmps;
2065     value = (I32) (anum & 255);
2066 #endif
2067     XPUSHi(value);
2068     RETURN;
2069 }
2070
2071 PP(pp_chr)
2072 {
2073     djSP; dTARGET;
2074     char *tmps;
2075
2076     (void)SvUPGRADE(TARG,SVt_PV);
2077     SvGROW(TARG,2);
2078     SvCUR_set(TARG, 1);
2079     tmps = SvPVX(TARG);
2080     *tmps++ = POPi;
2081     *tmps = '\0';
2082     (void)SvPOK_only(TARG);
2083     XPUSHs(TARG);
2084     RETURN;
2085 }
2086
2087 PP(pp_crypt)
2088 {
2089     djSP; dTARGET; dPOPTOPssrl;
2090 #ifdef HAS_CRYPT
2091     char *tmps = SvPV(left, na);
2092 #ifdef FCRYPT
2093     sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
2094 #else
2095     sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
2096 #endif
2097 #else
2098     DIE(
2099       "The crypt() function is unimplemented due to excessive paranoia.");
2100 #endif
2101     SETs(TARG);
2102     RETURN;
2103 }
2104
2105 PP(pp_ucfirst)
2106 {
2107     djSP;
2108     SV *sv = TOPs;
2109     register char *s;
2110
2111     if (!SvPADTMP(sv)) {
2112         dTARGET;
2113         sv_setsv(TARG, sv);
2114         sv = TARG;
2115         SETs(sv);
2116     }
2117     s = SvPV_force(sv, na);
2118     if (*s) {
2119         if (op->op_private & OPpLOCALE) {
2120             TAINT;
2121             SvTAINTED_on(sv);
2122             *s = toUPPER_LC(*s);
2123         }
2124         else
2125             *s = toUPPER(*s);
2126     }
2127
2128     RETURN;
2129 }
2130
2131 PP(pp_lcfirst)
2132 {
2133     djSP;
2134     SV *sv = TOPs;
2135     register char *s;
2136
2137     if (!SvPADTMP(sv)) {
2138         dTARGET;
2139         sv_setsv(TARG, sv);
2140         sv = TARG;
2141         SETs(sv);
2142     }
2143     s = SvPV_force(sv, na);
2144     if (*s) {
2145         if (op->op_private & OPpLOCALE) {
2146             TAINT;
2147             SvTAINTED_on(sv);
2148             *s = toLOWER_LC(*s);
2149         }
2150         else
2151             *s = toLOWER(*s);
2152     }
2153
2154     SETs(sv);
2155     RETURN;
2156 }
2157
2158 PP(pp_uc)
2159 {
2160     djSP;
2161     SV *sv = TOPs;
2162     register char *s;
2163     STRLEN len;
2164
2165     if (!SvPADTMP(sv)) {
2166         dTARGET;
2167         sv_setsv(TARG, sv);
2168         sv = TARG;
2169         SETs(sv);
2170     }
2171
2172     s = SvPV_force(sv, len);
2173     if (len) {
2174         register char *send = s + len;
2175
2176         if (op->op_private & OPpLOCALE) {
2177             TAINT;
2178             SvTAINTED_on(sv);
2179             for (; s < send; s++)
2180                 *s = toUPPER_LC(*s);
2181         }
2182         else {
2183             for (; s < send; s++)
2184                 *s = toUPPER(*s);
2185         }
2186     }
2187     RETURN;
2188 }
2189
2190 PP(pp_lc)
2191 {
2192     djSP;
2193     SV *sv = TOPs;
2194     register char *s;
2195     STRLEN len;
2196
2197     if (!SvPADTMP(sv)) {
2198         dTARGET;
2199         sv_setsv(TARG, sv);
2200         sv = TARG;
2201         SETs(sv);
2202     }
2203
2204     s = SvPV_force(sv, len);
2205     if (len) {
2206         register char *send = s + len;
2207
2208         if (op->op_private & OPpLOCALE) {
2209             TAINT;
2210             SvTAINTED_on(sv);
2211             for (; s < send; s++)
2212                 *s = toLOWER_LC(*s);
2213         }
2214         else {
2215             for (; s < send; s++)
2216                 *s = toLOWER(*s);
2217         }
2218     }
2219     RETURN;
2220 }
2221
2222 PP(pp_quotemeta)
2223 {
2224     djSP; dTARGET;
2225     SV *sv = TOPs;
2226     STRLEN len;
2227     register char *s = SvPV(sv,len);
2228     register char *d;
2229
2230     if (len) {
2231         (void)SvUPGRADE(TARG, SVt_PV);
2232         SvGROW(TARG, (len * 2) + 1);
2233         d = SvPVX(TARG);
2234         while (len--) {
2235             if (!isALNUM(*s))
2236                 *d++ = '\\';
2237             *d++ = *s++;
2238         }
2239         *d = '\0';
2240         SvCUR_set(TARG, d - SvPVX(TARG));
2241         (void)SvPOK_only(TARG);
2242     }
2243     else
2244         sv_setpvn(TARG, s, len);
2245     SETs(TARG);
2246     RETURN;
2247 }
2248
2249 /* Arrays. */
2250
2251 PP(pp_aslice)
2252 {
2253     djSP; dMARK; dORIGMARK;
2254     register SV** svp;
2255     register AV* av = (AV*)POPs;
2256     register I32 lval = op->op_flags & OPf_MOD;
2257     I32 arybase = curcop->cop_arybase;
2258     I32 elem;
2259
2260     if (SvTYPE(av) == SVt_PVAV) {
2261         if (lval && op->op_private & OPpLVAL_INTRO) {
2262             I32 max = -1;
2263             for (svp = MARK + 1; svp <= SP; svp++) {
2264                 elem = SvIVx(*svp);
2265                 if (elem > max)
2266                     max = elem;
2267             }
2268             if (max > AvMAX(av))
2269                 av_extend(av, max);
2270         }
2271         while (++MARK <= SP) {
2272             elem = SvIVx(*MARK);
2273
2274             if (elem > 0)
2275                 elem -= arybase;
2276             svp = av_fetch(av, elem, lval);
2277             if (lval) {
2278                 if (!svp || *svp == &sv_undef)
2279                     DIE(no_aelem, elem);
2280                 if (op->op_private & OPpLVAL_INTRO)
2281                     save_aelem(av, elem, svp);
2282             }
2283             *MARK = svp ? *svp : &sv_undef;
2284         }
2285     }
2286     if (GIMME != G_ARRAY) {
2287         MARK = ORIGMARK;
2288         *++MARK = *SP;
2289         SP = MARK;
2290     }
2291     RETURN;
2292 }
2293
2294 /* Associative arrays. */
2295
2296 PP(pp_each)
2297 {
2298     djSP; dTARGET;
2299     HV *hash = (HV*)POPs;
2300     HE *entry;
2301     I32 gimme = GIMME_V;
2302     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2303
2304     PUTBACK;
2305     /* might clobber stack_sp */
2306     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2307     SPAGAIN;
2308
2309     EXTEND(SP, 2);
2310     if (entry) {
2311         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2312         if (gimme == G_ARRAY) {
2313             PUTBACK;
2314             /* might clobber stack_sp */
2315             sv_setsv(TARG, realhv ?
2316                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2317             SPAGAIN;
2318             PUSHs(TARG);
2319         }
2320     }
2321     else if (gimme == G_SCALAR)
2322         RETPUSHUNDEF;
2323
2324     RETURN;
2325 }
2326
2327 PP(pp_values)
2328 {
2329     return do_kv(ARGS);
2330 }
2331
2332 PP(pp_keys)
2333 {
2334     return do_kv(ARGS);
2335 }
2336
2337 PP(pp_delete)
2338 {
2339     djSP;
2340     I32 gimme = GIMME_V;
2341     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2342     SV *sv;
2343     HV *hv;
2344
2345     if (op->op_private & OPpSLICE) {
2346         dMARK; dORIGMARK;
2347         U32 hvtype;
2348         hv = (HV*)POPs;
2349         hvtype = SvTYPE(hv);
2350         while (++MARK <= SP) {
2351             if (hvtype == SVt_PVHV)
2352                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2353             else
2354                 DIE("Not a HASH reference");
2355             *MARK = sv ? sv : &sv_undef;
2356         }
2357         if (discard)
2358             SP = ORIGMARK;
2359         else if (gimme == G_SCALAR) {
2360             MARK = ORIGMARK;
2361             *++MARK = *SP;
2362             SP = MARK;
2363         }
2364     }
2365     else {
2366         SV *keysv = POPs;
2367         hv = (HV*)POPs;
2368         if (SvTYPE(hv) == SVt_PVHV)
2369             sv = hv_delete_ent(hv, keysv, discard, 0);
2370         else
2371             DIE("Not a HASH reference");
2372         if (!sv)
2373             sv = &sv_undef;
2374         if (!discard)
2375             PUSHs(sv);
2376     }
2377     RETURN;
2378 }
2379
2380 PP(pp_exists)
2381 {
2382     djSP;
2383     SV *tmpsv = POPs;
2384     HV *hv = (HV*)POPs;
2385     if (SvTYPE(hv) == SVt_PVHV) {
2386         if (hv_exists_ent(hv, tmpsv, 0))
2387             RETPUSHYES;
2388     } else if (SvTYPE(hv) == SVt_PVAV) {
2389         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2390             RETPUSHYES;
2391     } else {
2392         DIE("Not a HASH reference");
2393     }
2394     RETPUSHNO;
2395 }
2396
2397 PP(pp_hslice)
2398 {
2399     djSP; dMARK; dORIGMARK;
2400     register HV *hv = (HV*)POPs;
2401     register I32 lval = op->op_flags & OPf_MOD;
2402     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2403
2404     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2405         while (++MARK <= SP) {
2406             SV *keysv = *MARK;
2407             SV **svp;
2408             if (realhv) {
2409                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2410                 svp = he ? &HeVAL(he) : 0;
2411             } else {
2412                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2413             }
2414             if (lval) {
2415                 if (!svp || *svp == &sv_undef)
2416                     DIE(no_helem, SvPV(keysv, na));
2417                 if (op->op_private & OPpLVAL_INTRO)
2418                     save_helem(hv, keysv, svp);
2419             }
2420             *MARK = svp ? *svp : &sv_undef;
2421         }
2422     }
2423     if (GIMME != G_ARRAY) {
2424         MARK = ORIGMARK;
2425         *++MARK = *SP;
2426         SP = MARK;
2427     }
2428     RETURN;
2429 }
2430
2431 /* List operators. */
2432
2433 PP(pp_list)
2434 {
2435     djSP; dMARK;
2436     if (GIMME != G_ARRAY) {
2437         if (++MARK <= SP)
2438             *MARK = *SP;                /* unwanted list, return last item */
2439         else
2440             *MARK = &sv_undef;
2441         SP = MARK;
2442     }
2443     RETURN;
2444 }
2445
2446 PP(pp_lslice)
2447 {
2448     djSP;
2449     SV **lastrelem = stack_sp;
2450     SV **lastlelem = stack_base + POPMARK;
2451     SV **firstlelem = stack_base + POPMARK + 1;
2452     register SV **firstrelem = lastlelem + 1;
2453     I32 arybase = curcop->cop_arybase;
2454     I32 lval = op->op_flags & OPf_MOD;
2455     I32 is_something_there = lval;
2456
2457     register I32 max = lastrelem - lastlelem;
2458     register SV **lelem;
2459     register I32 ix;
2460
2461     if (GIMME != G_ARRAY) {
2462         ix = SvIVx(*lastlelem);
2463         if (ix < 0)
2464             ix += max;
2465         else
2466             ix -= arybase;
2467         if (ix < 0 || ix >= max)
2468             *firstlelem = &sv_undef;
2469         else
2470             *firstlelem = firstrelem[ix];
2471         SP = firstlelem;
2472         RETURN;
2473     }
2474
2475     if (max == 0) {
2476         SP = firstlelem - 1;
2477         RETURN;
2478     }
2479
2480     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2481         ix = SvIVx(*lelem);
2482         if (ix < 0) {
2483             ix += max;
2484             if (ix < 0)
2485                 *lelem = &sv_undef;
2486             else if (!(*lelem = firstrelem[ix]))
2487                 *lelem = &sv_undef;
2488         }
2489         else {
2490             ix -= arybase;
2491             if (ix >= max || !(*lelem = firstrelem[ix]))
2492                 *lelem = &sv_undef;
2493         }
2494         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2495             is_something_there = TRUE;
2496     }
2497     if (is_something_there)
2498         SP = lastlelem;
2499     else
2500         SP = firstlelem - 1;
2501     RETURN;
2502 }
2503
2504 PP(pp_anonlist)
2505 {
2506     djSP; dMARK; dORIGMARK;
2507     I32 items = SP - MARK;
2508     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2509     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2510     XPUSHs(av);
2511     RETURN;
2512 }
2513
2514 PP(pp_anonhash)
2515 {
2516     djSP; dMARK; dORIGMARK;
2517     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2518
2519     while (MARK < SP) {
2520         SV* key = *++MARK;
2521         SV *val = NEWSV(46, 0);
2522         if (MARK < SP)
2523             sv_setsv(val, *++MARK);
2524         else if (dowarn)
2525             warn("Odd number of elements in hash assignment");
2526         (void)hv_store_ent(hv,key,val,0);
2527     }
2528     SP = ORIGMARK;
2529     XPUSHs((SV*)hv);
2530     RETURN;
2531 }
2532
2533 PP(pp_splice)
2534 {
2535     djSP; dMARK; dORIGMARK;
2536     register AV *ary = (AV*)*++MARK;
2537     register SV **src;
2538     register SV **dst;
2539     register I32 i;
2540     register I32 offset;
2541     register I32 length;
2542     I32 newlen;
2543     I32 after;
2544     I32 diff;
2545     SV **tmparyval = 0;
2546     MAGIC *mg;
2547
2548     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2549         *MARK-- = mg->mg_obj;
2550         PUSHMARK(MARK);
2551         PUTBACK;
2552         ENTER;
2553         perl_call_method("SPLICE",GIMME_V);
2554         LEAVE;
2555         SPAGAIN;
2556         RETURN;
2557     }
2558
2559     SP++;
2560
2561     if (++MARK < SP) {
2562         offset = i = SvIVx(*MARK);
2563         if (offset < 0)
2564             offset += AvFILLp(ary) + 1;
2565         else
2566             offset -= curcop->cop_arybase;
2567         if (offset < 0)
2568             DIE(no_aelem, i);
2569         if (++MARK < SP) {
2570             length = SvIVx(*MARK++);
2571             if (length < 0) {
2572                 length += AvFILLp(ary) - offset + 1;
2573                 if (length < 0)
2574                     length = 0;
2575             }
2576         }
2577         else
2578             length = AvMAX(ary) + 1;            /* close enough to infinity */
2579     }
2580     else {
2581         offset = 0;
2582         length = AvMAX(ary) + 1;
2583     }
2584     if (offset > AvFILLp(ary) + 1)
2585         offset = AvFILLp(ary) + 1;
2586     after = AvFILLp(ary) + 1 - (offset + length);
2587     if (after < 0) {                            /* not that much array */
2588         length += after;                        /* offset+length now in array */
2589         after = 0;
2590         if (!AvALLOC(ary))
2591             av_extend(ary, 0);
2592     }
2593
2594     /* At this point, MARK .. SP-1 is our new LIST */
2595
2596     newlen = SP - MARK;
2597     diff = newlen - length;
2598     if (newlen && !AvREAL(ary)) {
2599         if (AvREIFY(ary))
2600             av_reify(ary);
2601         else
2602             assert(AvREAL(ary));                /* would leak, so croak */
2603     }
2604
2605     if (diff < 0) {                             /* shrinking the area */
2606         if (newlen) {
2607             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2608             Copy(MARK, tmparyval, newlen, SV*);
2609         }
2610
2611         MARK = ORIGMARK + 1;
2612         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2613             MEXTEND(MARK, length);
2614             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2615             if (AvREAL(ary)) {
2616                 EXTEND_MORTAL(length);
2617                 for (i = length, dst = MARK; i; i--) {
2618                     sv_2mortal(*dst);   /* free them eventualy */
2619                     dst++;
2620                 }
2621             }
2622             MARK += length - 1;
2623         }
2624         else {
2625             *MARK = AvARRAY(ary)[offset+length-1];
2626             if (AvREAL(ary)) {
2627                 sv_2mortal(*MARK);
2628                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2629                     SvREFCNT_dec(*dst++);       /* free them now */
2630             }
2631         }
2632         AvFILLp(ary) += diff;
2633
2634         /* pull up or down? */
2635
2636         if (offset < after) {                   /* easier to pull up */
2637             if (offset) {                       /* esp. if nothing to pull */
2638                 src = &AvARRAY(ary)[offset-1];
2639                 dst = src - diff;               /* diff is negative */
2640                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2641                     *dst-- = *src--;
2642             }
2643             dst = AvARRAY(ary);
2644             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2645             AvMAX(ary) += diff;
2646         }
2647         else {
2648             if (after) {                        /* anything to pull down? */
2649                 src = AvARRAY(ary) + offset + length;
2650                 dst = src + diff;               /* diff is negative */
2651                 Move(src, dst, after, SV*);
2652             }
2653             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2654                                                 /* avoid later double free */
2655         }
2656         i = -diff;
2657         while (i)
2658             dst[--i] = &sv_undef;
2659
2660         if (newlen) {
2661             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2662               newlen; newlen--) {
2663                 *dst = NEWSV(46, 0);
2664                 sv_setsv(*dst++, *src++);
2665             }
2666             Safefree(tmparyval);
2667         }
2668     }
2669     else {                                      /* no, expanding (or same) */
2670         if (length) {
2671             New(452, tmparyval, length, SV*);   /* so remember deletion */
2672             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2673         }
2674
2675         if (diff > 0) {                         /* expanding */
2676
2677             /* push up or down? */
2678
2679             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2680                 if (offset) {
2681                     src = AvARRAY(ary);
2682                     dst = src - diff;
2683                     Move(src, dst, offset, SV*);
2684                 }
2685                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2686                 AvMAX(ary) += diff;
2687                 AvFILLp(ary) += diff;
2688             }
2689             else {
2690                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2691                     av_extend(ary, AvFILLp(ary) + diff);
2692                 AvFILLp(ary) += diff;
2693
2694                 if (after) {
2695                     dst = AvARRAY(ary) + AvFILLp(ary);
2696                     src = dst - diff;
2697                     for (i = after; i; i--) {
2698                         *dst-- = *src--;
2699                     }
2700                 }
2701             }
2702         }
2703
2704         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2705             *dst = NEWSV(46, 0);
2706             sv_setsv(*dst++, *src++);
2707         }
2708         MARK = ORIGMARK + 1;
2709         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2710             if (length) {
2711                 Copy(tmparyval, MARK, length, SV*);
2712                 if (AvREAL(ary)) {
2713                     EXTEND_MORTAL(length);
2714                     for (i = length, dst = MARK; i; i--) {
2715                         sv_2mortal(*dst);       /* free them eventualy */
2716                         dst++;
2717                     }
2718                 }
2719                 Safefree(tmparyval);
2720             }
2721             MARK += length - 1;
2722         }
2723         else if (length--) {
2724             *MARK = tmparyval[length];
2725             if (AvREAL(ary)) {
2726                 sv_2mortal(*MARK);
2727                 while (length-- > 0)
2728                     SvREFCNT_dec(tmparyval[length]);
2729             }
2730             Safefree(tmparyval);
2731         }
2732         else
2733             *MARK = &sv_undef;
2734     }
2735     SP = MARK;
2736     RETURN;
2737 }
2738
2739 PP(pp_push)
2740 {
2741     djSP; dMARK; dORIGMARK; dTARGET;
2742     register AV *ary = (AV*)*++MARK;
2743     register SV *sv = &sv_undef;
2744     MAGIC *mg;
2745
2746     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2747         *MARK-- = mg->mg_obj;
2748         PUSHMARK(MARK);
2749         PUTBACK;
2750         ENTER;
2751         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2752         LEAVE;
2753         SPAGAIN;
2754     }
2755     else {
2756         /* Why no pre-extend of ary here ? */
2757         for (++MARK; MARK <= SP; MARK++) {
2758             sv = NEWSV(51, 0);
2759             if (*MARK)
2760                 sv_setsv(sv, *MARK);
2761             av_push(ary, sv);
2762         }
2763     }
2764     SP = ORIGMARK;
2765     PUSHi( AvFILL(ary) + 1 );
2766     RETURN;
2767 }
2768
2769 PP(pp_pop)
2770 {
2771     djSP;
2772     AV *av = (AV*)POPs;
2773     SV *sv = av_pop(av);
2774     if (AvREAL(av))
2775         (void)sv_2mortal(sv);
2776     PUSHs(sv);
2777     RETURN;
2778 }
2779
2780 PP(pp_shift)
2781 {
2782     djSP;
2783     AV *av = (AV*)POPs;
2784     SV *sv = av_shift(av);
2785     EXTEND(SP, 1);
2786     if (!sv)
2787         RETPUSHUNDEF;
2788     if (AvREAL(av))
2789         (void)sv_2mortal(sv);
2790     PUSHs(sv);
2791     RETURN;
2792 }
2793
2794 PP(pp_unshift)
2795 {
2796     djSP; dMARK; dORIGMARK; dTARGET;
2797     register AV *ary = (AV*)*++MARK;
2798     register SV *sv;
2799     register I32 i = 0;
2800     MAGIC *mg;
2801
2802     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2803         *MARK-- = mg->mg_obj;
2804         PUSHMARK(MARK);
2805         PUTBACK;
2806         ENTER;
2807         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2808         LEAVE;
2809         SPAGAIN;
2810     }
2811     else {
2812         av_unshift(ary, SP - MARK);
2813         while (MARK < SP) {
2814             sv = NEWSV(27, 0);
2815             sv_setsv(sv, *++MARK);
2816             (void)av_store(ary, i++, sv);
2817         }
2818     }
2819     SP = ORIGMARK;
2820     PUSHi( AvFILL(ary) + 1 );
2821     RETURN;
2822 }
2823
2824 PP(pp_reverse)
2825 {
2826     djSP; dMARK;
2827     register SV *tmp;
2828     SV **oldsp = SP;
2829
2830     if (GIMME == G_ARRAY) {
2831         MARK++;
2832         while (MARK < SP) {
2833             tmp = *MARK;
2834             *MARK++ = *SP;
2835             *SP-- = tmp;
2836         }
2837         SP = oldsp;
2838     }
2839     else {
2840         register char *up;
2841         register char *down;
2842         register I32 tmp;
2843         dTARGET;
2844         STRLEN len;
2845
2846         if (SP - MARK > 1)
2847             do_join(TARG, &sv_no, MARK, SP);
2848         else
2849             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2850         up = SvPV_force(TARG, len);
2851         if (len > 1) {
2852             down = SvPVX(TARG) + len - 1;
2853             while (down > up) {
2854                 tmp = *up;
2855                 *up++ = *down;
2856                 *down-- = tmp;
2857             }
2858             (void)SvPOK_only(TARG);
2859         }
2860         SP = MARK + 1;
2861         SETTARG;
2862     }
2863     RETURN;
2864 }
2865
2866 STATIC SV      *
2867 mul128(SV *sv, U8 m)
2868 {
2869   STRLEN          len;
2870   char           *s = SvPV(sv, len);
2871   char           *t;
2872   U32             i = 0;
2873
2874   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
2875     SV             *tmpNew = newSVpv("0000000000", 10);
2876
2877     sv_catsv(tmpNew, sv);
2878     SvREFCNT_dec(sv);           /* free old sv */
2879     sv = tmpNew;
2880     s = SvPV(sv, len);
2881   }
2882   t = s + len - 1;
2883   while (!*t)                   /* trailing '\0'? */
2884     t--;
2885   while (t > s) {
2886     i = ((*t - '0') << 7) + m;
2887     *(t--) = '0' + (i % 10);
2888     m = i / 10;
2889   }
2890   return (sv);
2891 }
2892
2893 /* Explosives and implosives. */
2894
2895 PP(pp_unpack)
2896 {
2897     djSP;
2898     dPOPPOPssrl;
2899     SV **oldsp = SP;
2900     I32 gimme = GIMME_V;
2901     SV *sv;
2902     STRLEN llen;
2903     STRLEN rlen;
2904     register char *pat = SvPV(left, llen);
2905     register char *s = SvPV(right, rlen);
2906     char *strend = s + rlen;
2907     char *strbeg = s;
2908     register char *patend = pat + llen;
2909     I32 datumtype;
2910     register I32 len;
2911     register I32 bits;
2912
2913     /* These must not be in registers: */
2914     I16 ashort;
2915     int aint;
2916     I32 along;
2917 #ifdef HAS_QUAD
2918     Quad_t aquad;
2919 #endif
2920     U16 aushort;
2921     unsigned int auint;
2922     U32 aulong;
2923 #ifdef HAS_QUAD
2924     unsigned Quad_t auquad;
2925 #endif
2926     char *aptr;
2927     float afloat;
2928     double adouble;
2929     I32 checksum = 0;
2930     register U32 culong;
2931     double cdouble;
2932     static char* bitcount = 0;
2933     int commas = 0;
2934
2935     if (gimme != G_ARRAY) {             /* arrange to do first one only */
2936         /*SUPPRESS 530*/
2937         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2938         if (strchr("aAbBhHP", *patend) || *pat == '%') {
2939             patend++;
2940             while (isDIGIT(*patend) || *patend == '*')
2941                 patend++;
2942         }
2943         else
2944             patend++;
2945     }
2946     while (pat < patend) {
2947       reparse:
2948         datumtype = *pat++ & 0xFF;
2949         if (isSPACE(datumtype))
2950             continue;
2951         if (pat >= patend)
2952             len = 1;
2953         else if (*pat == '*') {
2954             len = strend - strbeg;      /* long enough */
2955             pat++;
2956         }
2957         else if (isDIGIT(*pat)) {
2958             len = *pat++ - '0';
2959             while (isDIGIT(*pat))
2960                 len = (len * 10) + (*pat++ - '0');
2961         }
2962         else
2963             len = (datumtype != '@');
2964         switch(datumtype) {
2965         default:
2966             croak("Invalid type in unpack: '%c'", (int)datumtype);
2967         case ',': /* grandfather in commas but with a warning */
2968             if (commas++ == 0 && dowarn)
2969                 warn("Invalid type in unpack: '%c'", (int)datumtype);
2970             break;
2971         case '%':
2972             if (len == 1 && pat[-1] != '1')
2973                 len = 16;
2974             checksum = len;
2975             culong = 0;
2976             cdouble = 0;
2977             if (pat < patend)
2978                 goto reparse;
2979             break;
2980         case '@':
2981             if (len > strend - strbeg)
2982                 DIE("@ outside of string");
2983             s = strbeg + len;
2984             break;
2985         case 'X':
2986             if (len > s - strbeg)
2987                 DIE("X outside of string");
2988             s -= len;
2989             break;
2990         case 'x':
2991             if (len > strend - s)
2992                 DIE("x outside of string");
2993             s += len;
2994             break;
2995         case 'A':
2996         case 'a':
2997             if (len > strend - s)
2998                 len = strend - s;
2999             if (checksum)
3000                 goto uchar_checksum;
3001             sv = NEWSV(35, len);
3002             sv_setpvn(sv, s, len);
3003             s += len;
3004             if (datumtype == 'A') {
3005                 aptr = s;       /* borrow register */
3006                 s = SvPVX(sv) + len - 1;
3007                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3008                     s--;
3009                 *++s = '\0';
3010                 SvCUR_set(sv, s - SvPVX(sv));
3011                 s = aptr;       /* unborrow register */
3012             }
3013             XPUSHs(sv_2mortal(sv));
3014             break;
3015         case 'B':
3016         case 'b':
3017             if (pat[-1] == '*' || len > (strend - s) * 8)
3018                 len = (strend - s) * 8;
3019             if (checksum) {
3020                 if (!bitcount) {
3021                     Newz(601, bitcount, 256, char);
3022                     for (bits = 1; bits < 256; bits++) {
3023                         if (bits & 1)   bitcount[bits]++;
3024                         if (bits & 2)   bitcount[bits]++;
3025                         if (bits & 4)   bitcount[bits]++;
3026                         if (bits & 8)   bitcount[bits]++;
3027                         if (bits & 16)  bitcount[bits]++;
3028                         if (bits & 32)  bitcount[bits]++;
3029                         if (bits & 64)  bitcount[bits]++;
3030                         if (bits & 128) bitcount[bits]++;
3031                     }
3032                 }
3033                 while (len >= 8) {
3034                     culong += bitcount[*(unsigned char*)s++];
3035                     len -= 8;
3036                 }
3037                 if (len) {
3038                     bits = *s;
3039                     if (datumtype == 'b') {
3040                         while (len-- > 0) {
3041                             if (bits & 1) culong++;
3042                             bits >>= 1;
3043                         }
3044                     }
3045                     else {
3046                         while (len-- > 0) {
3047                             if (bits & 128) culong++;
3048                             bits <<= 1;
3049                         }
3050                     }
3051                 }
3052                 break;
3053             }
3054             sv = NEWSV(35, len + 1);
3055             SvCUR_set(sv, len);
3056             SvPOK_on(sv);
3057             aptr = pat;                 /* borrow register */
3058             pat = SvPVX(sv);
3059             if (datumtype == 'b') {
3060                 aint = len;
3061                 for (len = 0; len < aint; len++) {
3062                     if (len & 7)                /*SUPPRESS 595*/
3063                         bits >>= 1;
3064                     else
3065                         bits = *s++;
3066                     *pat++ = '0' + (bits & 1);
3067                 }
3068             }
3069             else {
3070                 aint = len;
3071                 for (len = 0; len < aint; len++) {
3072                     if (len & 7)
3073                         bits <<= 1;
3074                     else
3075                         bits = *s++;
3076                     *pat++ = '0' + ((bits & 128) != 0);
3077                 }
3078             }
3079             *pat = '\0';
3080             pat = aptr;                 /* unborrow register */
3081             XPUSHs(sv_2mortal(sv));
3082             break;
3083         case 'H':
3084         case 'h':
3085             if (pat[-1] == '*' || len > (strend - s) * 2)
3086                 len = (strend - s) * 2;
3087             sv = NEWSV(35, len + 1);
3088             SvCUR_set(sv, len);
3089             SvPOK_on(sv);
3090             aptr = pat;                 /* borrow register */
3091             pat = SvPVX(sv);
3092             if (datumtype == 'h') {
3093                 aint = len;
3094                 for (len = 0; len < aint; len++) {
3095                     if (len & 1)
3096                         bits >>= 4;
3097                     else
3098                         bits = *s++;
3099                     *pat++ = hexdigit[bits & 15];
3100                 }
3101             }
3102             else {
3103                 aint = len;
3104                 for (len = 0; len < aint; len++) {
3105                     if (len & 1)
3106                         bits <<= 4;
3107                     else
3108                         bits = *s++;
3109                     *pat++ = hexdigit[(bits >> 4) & 15];
3110                 }
3111             }
3112             *pat = '\0';
3113             pat = aptr;                 /* unborrow register */
3114             XPUSHs(sv_2mortal(sv));
3115             break;
3116         case 'c':
3117             if (len > strend - s)
3118                 len = strend - s;
3119             if (checksum) {
3120                 while (len-- > 0) {
3121                     aint = *s++;
3122                     if (aint >= 128)    /* fake up signed chars */
3123                         aint -= 256;
3124                     culong += aint;
3125                 }
3126             }
3127             else {
3128                 EXTEND(SP, len);
3129                 EXTEND_MORTAL(len);
3130                 while (len-- > 0) {
3131                     aint = *s++;
3132                     if (aint >= 128)    /* fake up signed chars */
3133                         aint -= 256;
3134                     sv = NEWSV(36, 0);
3135                     sv_setiv(sv, (IV)aint);
3136                     PUSHs(sv_2mortal(sv));
3137                 }
3138             }
3139             break;
3140         case 'C':
3141             if (len > strend - s)
3142                 len = strend - s;
3143             if (checksum) {
3144               uchar_checksum:
3145                 while (len-- > 0) {
3146                     auint = *s++ & 255;
3147                     culong += auint;
3148                 }
3149             }
3150             else {
3151                 EXTEND(SP, len);
3152                 EXTEND_MORTAL(len);
3153                 while (len-- > 0) {
3154                     auint = *s++ & 255;
3155                     sv = NEWSV(37, 0);
3156                     sv_setiv(sv, (IV)auint);
3157                     PUSHs(sv_2mortal(sv));
3158                 }
3159             }
3160             break;
3161         case 's':
3162             along = (strend - s) / SIZE16;
3163             if (len > along)
3164                 len = along;
3165             if (checksum) {
3166                 while (len-- > 0) {
3167                     COPY16(s, &ashort);
3168                     s += SIZE16;
3169                     culong += ashort;
3170                 }
3171             }
3172             else {
3173                 EXTEND(SP, len);
3174                 EXTEND_MORTAL(len);
3175                 while (len-- > 0) {
3176                     COPY16(s, &ashort);
3177                     s += SIZE16;
3178                     sv = NEWSV(38, 0);
3179                     sv_setiv(sv, (IV)ashort);
3180                     PUSHs(sv_2mortal(sv));
3181                 }
3182             }
3183             break;
3184         case 'v':
3185         case 'n':
3186         case 'S':
3187             along = (strend - s) / SIZE16;
3188             if (len > along)
3189                 len = along;
3190             if (checksum) {
3191                 while (len-- > 0) {
3192                     COPY16(s, &aushort);
3193                     s += SIZE16;
3194 #ifdef HAS_NTOHS
3195                     if (datumtype == 'n')
3196                         aushort = PerlSock_ntohs(aushort);
3197 #endif
3198 #ifdef HAS_VTOHS
3199                     if (datumtype == 'v')
3200                         aushort = vtohs(aushort);
3201 #endif
3202                     culong += aushort;
3203                 }
3204             }
3205             else {
3206                 EXTEND(SP, len);
3207                 EXTEND_MORTAL(len);
3208                 while (len-- > 0) {
3209                     COPY16(s, &aushort);
3210                     s += SIZE16;
3211                     sv = NEWSV(39, 0);
3212 #ifdef HAS_NTOHS
3213                     if (datumtype == 'n')
3214                         aushort = PerlSock_ntohs(aushort);
3215 #endif
3216 #ifdef HAS_VTOHS
3217                     if (datumtype == 'v')
3218                         aushort = vtohs(aushort);
3219 #endif
3220                     sv_setiv(sv, (IV)aushort);
3221                     PUSHs(sv_2mortal(sv));
3222                 }
3223             }
3224             break;
3225         case 'i':
3226             along = (strend - s) / sizeof(int);
3227             if (len > along)
3228                 len = along;
3229             if (checksum) {
3230                 while (len-- > 0) {
3231                     Copy(s, &aint, 1, int);
3232                     s += sizeof(int);
3233                     if (checksum > 32)
3234                         cdouble += (double)aint;
3235                     else
3236                         culong += aint;
3237                 }
3238             }
3239             else {
3240                 EXTEND(SP, len);
3241                 EXTEND_MORTAL(len);
3242                 while (len-- > 0) {
3243                     Copy(s, &aint, 1, int);
3244                     s += sizeof(int);
3245                     sv = NEWSV(40, 0);
3246 #ifdef __osf__
3247                     /* Without the dummy below unpack("i", pack("i",-1))
3248                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3249                      * cc with optimization turned on */
3250                     (aint) ?
3251                         sv_setiv(sv, (IV)aint) :
3252 #endif
3253                     sv_setiv(sv, (IV)aint);
3254                     PUSHs(sv_2mortal(sv));
3255                 }
3256             }
3257             break;
3258         case 'I':
3259             along = (strend - s) / sizeof(unsigned int);
3260             if (len > along)
3261                 len = along;
3262             if (checksum) {
3263                 while (len-- > 0) {
3264                     Copy(s, &auint, 1, unsigned int);
3265                     s += sizeof(unsigned int);
3266                     if (checksum > 32)
3267                         cdouble += (double)auint;
3268                     else
3269                         culong += auint;
3270                 }
3271             }
3272             else {
3273                 EXTEND(SP, len);
3274                 EXTEND_MORTAL(len);
3275                 while (len-- > 0) {
3276                     Copy(s, &auint, 1, unsigned int);
3277                     s += sizeof(unsigned int);
3278                     sv = NEWSV(41, 0);
3279                     sv_setuv(sv, (UV)auint);
3280                     PUSHs(sv_2mortal(sv));
3281                 }
3282             }
3283             break;
3284         case 'l':
3285             along = (strend - s) / SIZE32;
3286             if (len > along)
3287                 len = along;
3288             if (checksum) {
3289                 while (len-- > 0) {
3290                     COPY32(s, &along);
3291                     s += SIZE32;
3292                     if (checksum > 32)
3293                         cdouble += (double)along;
3294                     else
3295                         culong += along;
3296                 }
3297             }
3298             else {
3299                 EXTEND(SP, len);
3300                 EXTEND_MORTAL(len);
3301                 while (len-- > 0) {
3302                     COPY32(s, &along);
3303                     s += SIZE32;
3304                     sv = NEWSV(42, 0);
3305                     sv_setiv(sv, (IV)along);
3306                     PUSHs(sv_2mortal(sv));
3307                 }
3308             }
3309             break;
3310         case 'V':
3311         case 'N':
3312         case 'L':
3313             along = (strend - s) / SIZE32;
3314             if (len > along)
3315                 len = along;
3316             if (checksum) {
3317                 while (len-- > 0) {
3318                     COPY32(s, &aulong);
3319                     s += SIZE32;
3320 #ifdef HAS_NTOHL
3321                     if (datumtype == 'N')
3322                         aulong = PerlSock_ntohl(aulong);
3323 #endif
3324 #ifdef HAS_VTOHL
3325                     if (datumtype == 'V')
3326                         aulong = vtohl(aulong);
3327 #endif
3328                     if (checksum > 32)
3329                         cdouble += (double)aulong;
3330                     else
3331                         culong += aulong;
3332                 }
3333             }
3334             else {
3335                 EXTEND(SP, len);
3336                 EXTEND_MORTAL(len);
3337                 while (len-- > 0) {
3338                     COPY32(s, &aulong);
3339                     s += SIZE32;
3340 #ifdef HAS_NTOHL
3341                     if (datumtype == 'N')
3342                         aulong = PerlSock_ntohl(aulong);
3343 #endif
3344 #ifdef HAS_VTOHL
3345                     if (datumtype == 'V')
3346                         aulong = vtohl(aulong);
3347 #endif
3348                     sv = NEWSV(43, 0);
3349                     sv_setuv(sv, (UV)aulong);
3350                     PUSHs(sv_2mortal(sv));
3351                 }
3352             }
3353             break;
3354         case 'p':
3355             along = (strend - s) / sizeof(char*);
3356             if (len > along)
3357                 len = along;
3358             EXTEND(SP, len);
3359             EXTEND_MORTAL(len);
3360             while (len-- > 0) {
3361                 if (sizeof(char*) > strend - s)
3362                     break;
3363                 else {
3364                     Copy(s, &aptr, 1, char*);
3365                     s += sizeof(char*);
3366                 }
3367                 sv = NEWSV(44, 0);
3368                 if (aptr)
3369                     sv_setpv(sv, aptr);
3370                 PUSHs(sv_2mortal(sv));
3371             }
3372             break;
3373         case 'w':
3374             EXTEND(SP, len);
3375             EXTEND_MORTAL(len);
3376             {
3377                 UV auv = 0;
3378                 U32 bytes = 0;
3379
3380                 while ((len > 0) && (s < strend)) {
3381                     auv = (auv << 7) | (*s & 0x7f);
3382                     if (!(*s++ & 0x80)) {
3383                         bytes = 0;
3384                         sv = NEWSV(40, 0);
3385                         sv_setuv(sv, auv);
3386                         PUSHs(sv_2mortal(sv));
3387                         len--;
3388                         auv = 0;
3389                     }
3390                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3391                         char *t;
3392
3393                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3394                         while (s < strend) {
3395                             sv = mul128(sv, *s & 0x7f);
3396                             if (!(*s++ & 0x80)) {
3397                                 bytes = 0;
3398                                 break;
3399                             }
3400                         }
3401                         t = SvPV(sv, na);
3402                         while (*t == '0')
3403                             t++;
3404                         sv_chop(sv, t);
3405                         PUSHs(sv_2mortal(sv));
3406                         len--;
3407                         auv = 0;
3408                     }
3409                 }
3410                 if ((s >= strend) && bytes)
3411                     croak("Unterminated compressed integer");
3412             }
3413             break;
3414         case 'P':
3415             EXTEND(SP, 1);
3416             if (sizeof(char*) > strend - s)
3417                 break;
3418             else {
3419                 Copy(s, &aptr, 1, char*);
3420                 s += sizeof(char*);
3421             }
3422             sv = NEWSV(44, 0);
3423             if (aptr)
3424                 sv_setpvn(sv, aptr, len);
3425             PUSHs(sv_2mortal(sv));
3426             break;
3427 #ifdef HAS_QUAD
3428         case 'q':
3429             along = (strend - s) / sizeof(Quad_t);
3430             if (len > along)
3431                 len = along;
3432             EXTEND(SP, len);
3433             EXTEND_MORTAL(len);
3434             while (len-- > 0) {
3435                 if (s + sizeof(Quad_t) > strend)
3436                     aquad = 0;
3437                 else {
3438                     Copy(s, &aquad, 1, Quad_t);
3439                     s += sizeof(Quad_t);
3440                 }
3441                 sv = NEWSV(42, 0);
3442                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3443                     sv_setiv(sv, (IV)aquad);
3444                 else
3445                     sv_setnv(sv, (double)aquad);
3446                 PUSHs(sv_2mortal(sv));
3447             }
3448             break;
3449         case 'Q':
3450             along = (strend - s) / sizeof(Quad_t);
3451             if (len > along)
3452                 len = along;
3453             EXTEND(SP, len);
3454             EXTEND_MORTAL(len);
3455             while (len-- > 0) {
3456                 if (s + sizeof(unsigned Quad_t) > strend)
3457                     auquad = 0;
3458                 else {
3459                     Copy(s, &auquad, 1, unsigned Quad_t);
3460                     s += sizeof(unsigned Quad_t);
3461                 }
3462                 sv = NEWSV(43, 0);
3463                 if (auquad <= UV_MAX)
3464                     sv_setuv(sv, (UV)auquad);
3465                 else
3466                     sv_setnv(sv, (double)auquad);
3467                 PUSHs(sv_2mortal(sv));
3468             }
3469             break;
3470 #endif
3471         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3472         case 'f':
3473         case 'F':
3474             along = (strend - s) / sizeof(float);
3475             if (len > along)
3476                 len = along;
3477             if (checksum) {
3478                 while (len-- > 0) {
3479                     Copy(s, &afloat, 1, float);
3480                     s += sizeof(float);
3481                     cdouble += afloat;
3482                 }
3483             }
3484             else {
3485                 EXTEND(SP, len);
3486                 EXTEND_MORTAL(len);
3487                 while (len-- > 0) {
3488                     Copy(s, &afloat, 1, float);
3489                     s += sizeof(float);
3490                     sv = NEWSV(47, 0);
3491                     sv_setnv(sv, (double)afloat);
3492                     PUSHs(sv_2mortal(sv));
3493                 }
3494             }
3495             break;
3496         case 'd':
3497         case 'D':
3498             along = (strend - s) / sizeof(double);
3499             if (len > along)
3500                 len = along;
3501             if (checksum) {
3502                 while (len-- > 0) {
3503                     Copy(s, &adouble, 1, double);
3504                     s += sizeof(double);
3505                     cdouble += adouble;
3506                 }
3507             }
3508             else {
3509                 EXTEND(SP, len);
3510                 EXTEND_MORTAL(len);
3511                 while (len-- > 0) {
3512                     Copy(s, &adouble, 1, double);
3513                     s += sizeof(double);
3514                     sv = NEWSV(48, 0);
3515                     sv_setnv(sv, (double)adouble);
3516                     PUSHs(sv_2mortal(sv));
3517                 }
3518             }
3519             break;
3520         case 'u':
3521             along = (strend - s) * 3 / 4;
3522             sv = NEWSV(42, along);
3523             if (along)
3524                 SvPOK_on(sv);
3525             while (s < strend && *s > ' ' && *s < 'a') {
3526                 I32 a, b, c, d;
3527                 char hunk[4];
3528
3529                 hunk[3] = '\0';
3530                 len = (*s++ - ' ') & 077;
3531                 while (len > 0) {
3532                     if (s < strend && *s >= ' ')
3533                         a = (*s++ - ' ') & 077;
3534                     else
3535                         a = 0;
3536                     if (s < strend && *s >= ' ')
3537                         b = (*s++ - ' ') & 077;
3538                     else
3539                         b = 0;
3540                     if (s < strend && *s >= ' ')
3541                         c = (*s++ - ' ') & 077;
3542                     else
3543                         c = 0;
3544                     if (s < strend && *s >= ' ')
3545                         d = (*s++ - ' ') & 077;
3546                     else
3547                         d = 0;
3548                     hunk[0] = (a << 2) | (b >> 4);
3549                     hunk[1] = (b << 4) | (c >> 2);
3550                     hunk[2] = (c << 6) | d;
3551                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3552                     len -= 3;
3553                 }
3554                 if (*s == '\n')
3555                     s++;
3556                 else if (s[1] == '\n')          /* possible checksum byte */
3557                     s += 2;
3558             }
3559             XPUSHs(sv_2mortal(sv));
3560             break;
3561         }
3562         if (checksum) {
3563             sv = NEWSV(42, 0);
3564             if (strchr("fFdD", datumtype) ||
3565               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3566                 double trouble;
3567
3568                 adouble = 1.0;
3569                 while (checksum >= 16) {
3570                     checksum -= 16;
3571                     adouble *= 65536.0;
3572                 }
3573                 while (checksum >= 4) {
3574                     checksum -= 4;
3575                     adouble *= 16.0;
3576                 }
3577                 while (checksum--)
3578                     adouble *= 2.0;
3579                 along = (1 << checksum) - 1;
3580                 while (cdouble < 0.0)
3581                     cdouble += adouble;
3582                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3583                 sv_setnv(sv, cdouble);
3584             }
3585             else {
3586                 if (checksum < 32) {
3587                     aulong = (1 << checksum) - 1;
3588                     culong &= aulong;
3589                 }
3590                 sv_setuv(sv, (UV)culong);
3591             }
3592             XPUSHs(sv_2mortal(sv));
3593             checksum = 0;
3594         }
3595     }
3596     if (SP == oldsp && gimme == G_SCALAR)
3597         PUSHs(&sv_undef);
3598     RETURN;
3599 }
3600
3601 STATIC void
3602 doencodes(register SV *sv, register char *s, register I32 len)
3603 {
3604     char hunk[5];
3605
3606     *hunk = len + ' ';
3607     sv_catpvn(sv, hunk, 1);
3608     hunk[4] = '\0';
3609     while (len > 0) {
3610         hunk[0] = ' ' + (077 & (*s >> 2));
3611         hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3612         hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3613         hunk[3] = ' ' + (077 & (s[2] & 077));
3614         sv_catpvn(sv, hunk, 4);
3615         s += 3;
3616         len -= 3;
3617     }
3618     for (s = SvPVX(sv); *s; s++) {
3619         if (*s == ' ')
3620             *s = '`';
3621     }
3622     sv_catpvn(sv, "\n", 1);
3623 }
3624
3625 STATIC SV      *
3626 is_an_int(char *s, STRLEN l)
3627 {
3628   SV             *result = newSVpv("", l);
3629   char           *result_c = SvPV(result, na);  /* convenience */
3630   char           *out = result_c;
3631   bool            skip = 1;
3632   bool            ignore = 0;
3633
3634   while (*s) {
3635     switch (*s) {
3636     case ' ':
3637       break;
3638     case '+':
3639       if (!skip) {
3640         SvREFCNT_dec(result);
3641         return (NULL);
3642       }
3643       break;
3644     case '0':
3645     case '1':
3646     case '2':
3647     case '3':
3648     case '4':
3649     case '5':
3650     case '6':
3651     case '7':
3652     case '8':
3653     case '9':
3654       skip = 0;
3655       if (!ignore) {
3656         *(out++) = *s;
3657       }
3658       break;
3659     case '.':
3660       ignore = 1;
3661       break;
3662     default:
3663       SvREFCNT_dec(result);
3664       return (NULL);
3665     }
3666     s++;
3667   }
3668   *(out++) = '\0';
3669   SvCUR_set(result, out - result_c);
3670   return (result);
3671 }
3672
3673 STATIC int
3674 div128(SV *pnum, bool *done)
3675                                             /* must be '\0' terminated */
3676
3677 {
3678   STRLEN          len;
3679   char           *s = SvPV(pnum, len);
3680   int             m = 0;
3681   int             r = 0;
3682   char           *t = s;
3683
3684   *done = 1;
3685   while (*t) {
3686     int             i;
3687
3688     i = m * 10 + (*t - '0');
3689     m = i & 0x7F;
3690     r = (i >> 7);               /* r < 10 */
3691     if (r) {
3692       *done = 0;
3693     }
3694     *(t++) = '0' + r;
3695   }
3696   *(t++) = '\0';
3697   SvCUR_set(pnum, (STRLEN) (t - s));
3698   return (m);
3699 }
3700
3701
3702 PP(pp_pack)
3703 {
3704     djSP; dMARK; dORIGMARK; dTARGET;
3705     register SV *cat = TARG;
3706     register I32 items;
3707     STRLEN fromlen;
3708     register char *pat = SvPVx(*++MARK, fromlen);
3709     register char *patend = pat + fromlen;
3710     register I32 len;
3711     I32 datumtype;
3712     SV *fromstr;
3713     /*SUPPRESS 442*/
3714     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3715     static char *space10 = "          ";
3716
3717     /* These must not be in registers: */
3718     char achar;
3719     I16 ashort;
3720     int aint;
3721     unsigned int auint;
3722     I32 along;
3723     U32 aulong;
3724 #ifdef HAS_QUAD
3725     Quad_t aquad;
3726     unsigned Quad_t auquad;
3727 #endif
3728     char *aptr;
3729     float afloat;
3730     double adouble;
3731     int commas = 0;
3732
3733     items = SP - MARK;
3734     MARK++;
3735     sv_setpvn(cat, "", 0);
3736     while (pat < patend) {
3737 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3738         datumtype = *pat++ & 0xFF;
3739         if (isSPACE(datumtype))
3740             continue;
3741         if (*pat == '*') {
3742             len = strchr("@Xxu", datumtype) ? 0 : items;
3743             pat++;
3744         }
3745         else if (isDIGIT(*pat)) {
3746             len = *pat++ - '0';
3747             while (isDIGIT(*pat))
3748                 len = (len * 10) + (*pat++ - '0');
3749         }
3750         else
3751             len = 1;
3752         switch(datumtype) {
3753         default:
3754             croak("Invalid type in pack: '%c'", (int)datumtype);
3755         case ',': /* grandfather in commas but with a warning */
3756             if (commas++ == 0 && dowarn)
3757                 warn("Invalid type in pack: '%c'", (int)datumtype);
3758             break;
3759         case '%':
3760             DIE("%% may only be used in unpack");
3761         case '@':
3762             len -= SvCUR(cat);
3763             if (len > 0)
3764                 goto grow;
3765             len = -len;
3766             if (len > 0)
3767                 goto shrink;
3768             break;
3769         case 'X':
3770           shrink:
3771             if (SvCUR(cat) < len)
3772                 DIE("X outside of string");
3773             SvCUR(cat) -= len;
3774             *SvEND(cat) = '\0';
3775             break;
3776         case 'x':
3777           grow:
3778             while (len >= 10) {
3779                 sv_catpvn(cat, null10, 10);
3780                 len -= 10;
3781             }
3782             sv_catpvn(cat, null10, len);
3783             break;
3784         case 'A':
3785         case 'a':
3786             fromstr = NEXTFROM;
3787             aptr = SvPV(fromstr, fromlen);
3788             if (pat[-1] == '*')
3789                 len = fromlen;
3790             if (fromlen > len)
3791                 sv_catpvn(cat, aptr, len);
3792             else {
3793                 sv_catpvn(cat, aptr, fromlen);
3794                 len -= fromlen;
3795                 if (datumtype == 'A') {
3796                     while (len >= 10) {
3797                         sv_catpvn(cat, space10, 10);
3798                         len -= 10;
3799                     }
3800                     sv_catpvn(cat, space10, len);
3801                 }
3802                 else {
3803                     while (len >= 10) {
3804                         sv_catpvn(cat, null10, 10);
3805                         len -= 10;
3806                     }
3807                     sv_catpvn(cat, null10, len);
3808                 }
3809             }
3810             break;
3811         case 'B':
3812         case 'b':
3813             {
3814                 char *savepat = pat;
3815                 I32 saveitems;
3816
3817                 fromstr = NEXTFROM;
3818                 saveitems = items;
3819                 aptr = SvPV(fromstr, fromlen);
3820                 if (pat[-1] == '*')
3821                     len = fromlen;
3822                 pat = aptr;
3823                 aint = SvCUR(cat);
3824                 SvCUR(cat) += (len+7)/8;
3825                 SvGROW(cat, SvCUR(cat) + 1);
3826                 aptr = SvPVX(cat) + aint;
3827                 if (len > fromlen)
3828                     len = fromlen;
3829                 aint = len;
3830                 items = 0;
3831                 if (datumtype == 'B') {
3832                     for (len = 0; len++ < aint;) {
3833                         items |= *pat++ & 1;
3834                         if (len & 7)
3835                             items <<= 1;
3836                         else {
3837                             *aptr++ = items & 0xff;
3838                             items = 0;
3839                         }
3840                     }
3841                 }
3842                 else {
3843                     for (len = 0; len++ < aint;) {
3844                         if (*pat++ & 1)
3845                             items |= 128;
3846                         if (len & 7)
3847                             items >>= 1;
3848                         else {
3849                             *aptr++ = items & 0xff;
3850                             items = 0;
3851                         }
3852                     }
3853                 }
3854                 if (aint & 7) {
3855                     if (datumtype == 'B')
3856                         items <<= 7 - (aint & 7);
3857                     else
3858                         items >>= 7 - (aint & 7);
3859                     *aptr++ = items & 0xff;
3860                 }
3861                 pat = SvPVX(cat) + SvCUR(cat);
3862                 while (aptr <= pat)
3863                     *aptr++ = '\0';
3864
3865                 pat = savepat;
3866                 items = saveitems;
3867             }
3868             break;
3869         case 'H':
3870         case 'h':
3871             {
3872                 char *savepat = pat;
3873                 I32 saveitems;
3874
3875                 fromstr = NEXTFROM;
3876                 saveitems = items;
3877                 aptr = SvPV(fromstr, fromlen);
3878                 if (pat[-1] == '*')
3879                     len = fromlen;
3880                 pat = aptr;
3881                 aint = SvCUR(cat);
3882                 SvCUR(cat) += (len+1)/2;
3883                 SvGROW(cat, SvCUR(cat) + 1);
3884                 aptr = SvPVX(cat) + aint;
3885                 if (len > fromlen)
3886                     len = fromlen;
3887                 aint = len;
3888                 items = 0;
3889                 if (datumtype == 'H') {
3890                     for (len = 0; len++ < aint;) {
3891                         if (isALPHA(*pat))
3892                             items |= ((*pat++ & 15) + 9) & 15;
3893                         else
3894                             items |= *pat++ & 15;
3895                         if (len & 1)
3896                             items <<= 4;
3897                         else {
3898                             *aptr++ = items & 0xff;
3899                             items = 0;
3900                         }
3901                     }
3902                 }
3903                 else {
3904                     for (len = 0; len++ < aint;) {
3905                         if (isALPHA(*pat))
3906                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3907                         else
3908                             items |= (*pat++ & 15) << 4;
3909                         if (len & 1)
3910                             items >>= 4;
3911                         else {
3912                             *aptr++ = items & 0xff;
3913                             items = 0;
3914                         }
3915                     }
3916                 }
3917                 if (aint & 1)
3918                     *aptr++ = items & 0xff;
3919                 pat = SvPVX(cat) + SvCUR(cat);
3920                 while (aptr <= pat)
3921                     *aptr++ = '\0';
3922
3923                 pat = savepat;
3924                 items = saveitems;
3925             }
3926             break;
3927         case 'C':
3928         case 'c':
3929             while (len-- > 0) {
3930                 fromstr = NEXTFROM;
3931                 aint = SvIV(fromstr);
3932                 achar = aint;
3933                 sv_catpvn(cat, &achar, sizeof(char));
3934             }
3935             break;
3936         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3937         case 'f':
3938         case 'F':
3939             while (len-- > 0) {
3940                 fromstr = NEXTFROM;
3941                 afloat = (float)SvNV(fromstr);
3942                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3943             }
3944             break;
3945         case 'd':
3946         case 'D':
3947             while (len-- > 0) {
3948                 fromstr = NEXTFROM;
3949                 adouble = (double)SvNV(fromstr);
3950                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3951             }
3952             break;
3953         case 'n':
3954             while (len-- > 0) {
3955                 fromstr = NEXTFROM;
3956                 ashort = (I16)SvIV(fromstr);
3957 #ifdef HAS_HTONS
3958                 ashort = PerlSock_htons(ashort);
3959 #endif
3960                 CAT16(cat, &ashort);
3961             }
3962             break;
3963         case 'v':
3964             while (len-- > 0) {
3965                 fromstr = NEXTFROM;
3966                 ashort = (I16)SvIV(fromstr);
3967 #ifdef HAS_HTOVS
3968                 ashort = htovs(ashort);
3969 #endif
3970                 CAT16(cat, &ashort);
3971             }
3972             break;
3973         case 'S':
3974         case 's':
3975             while (len-- > 0) {
3976                 fromstr = NEXTFROM;
3977                 ashort = (I16)SvIV(fromstr);
3978                 CAT16(cat, &ashort);
3979             }
3980             break;
3981         case 'I':
3982             while (len-- > 0) {
3983                 fromstr = NEXTFROM;
3984                 auint = SvUV(fromstr);
3985                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3986             }
3987             break;
3988         case 'w':
3989             while (len-- > 0) {
3990                 fromstr = NEXTFROM;
3991                 adouble = floor(SvNV(fromstr));
3992
3993                 if (adouble < 0)
3994                     croak("Cannot compress negative numbers");
3995
3996                 if (
3997 #ifdef BW_BITS
3998                     adouble <= BW_MASK
3999 #else
4000 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4001                     adouble <= UV_MAX_cxux
4002 #else
4003                     adouble <= UV_MAX
4004 #endif
4005 #endif
4006                     )
4007                 {
4008                     char   buf[1 + sizeof(UV)];
4009                     char  *in = buf + sizeof(buf);
4010                     UV     auv = U_V(adouble);;
4011
4012                     do {
4013                         *--in = (auv & 0x7f) | 0x80;
4014                         auv >>= 7;
4015                     } while (auv);
4016                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4017                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4018                 }
4019                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4020                     char           *from, *result, *in;
4021                     SV             *norm;
4022                     STRLEN          len;
4023                     bool            done;
4024
4025                     /* Copy string and check for compliance */
4026                     from = SvPV(fromstr, len);
4027                     if ((norm = is_an_int(from, len)) == NULL)
4028                         croak("can compress only unsigned integer");
4029
4030                     New('w', result, len, char);
4031                     in = result + len;
4032                     done = FALSE;
4033                     while (!done)
4034                         *--in = div128(norm, &done) | 0x80;
4035                     result[len - 1] &= 0x7F; /* clear continue bit */
4036                     sv_catpvn(cat, in, (result + len) - in);
4037                     Safefree(result);
4038                     SvREFCNT_dec(norm); /* free norm */
4039                 }
4040                 else if (SvNOKp(fromstr)) {
4041                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4042                     char  *in = buf + sizeof(buf);
4043
4044                     do {
4045                         double next = floor(adouble / 128);
4046                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4047                         if (--in < buf)  /* this cannot happen ;-) */
4048                             croak ("Cannot compress integer");
4049                         adouble = next;
4050                     } while (adouble > 0);
4051                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4052                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4053                 }
4054                 else
4055                     croak("Cannot compress non integer");
4056             }
4057             break;
4058         case 'i':
4059             while (len-- > 0) {
4060                 fromstr = NEXTFROM;
4061                 aint = SvIV(fromstr);
4062                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4063             }
4064             break;
4065         case 'N':
4066             while (len-- > 0) {
4067                 fromstr = NEXTFROM;
4068                 aulong = SvUV(fromstr);
4069 #ifdef HAS_HTONL
4070                 aulong = PerlSock_htonl(aulong);
4071 #endif
4072                 CAT32(cat, &aulong);
4073             }
4074             break;
4075         case 'V':
4076             while (len-- > 0) {
4077                 fromstr = NEXTFROM;
4078                 aulong = SvUV(fromstr);
4079 #ifdef HAS_HTOVL
4080                 aulong = htovl(aulong);
4081 #endif
4082                 CAT32(cat, &aulong);
4083             }
4084             break;
4085         case 'L':
4086             while (len-- > 0) {
4087                 fromstr = NEXTFROM;
4088                 aulong = SvUV(fromstr);
4089                 CAT32(cat, &aulong);
4090             }
4091             break;
4092         case 'l':
4093             while (len-- > 0) {
4094                 fromstr = NEXTFROM;
4095                 along = SvIV(fromstr);
4096                 CAT32(cat, &along);
4097             }
4098             break;
4099 #ifdef HAS_QUAD
4100         case 'Q':
4101             while (len-- > 0) {
4102                 fromstr = NEXTFROM;
4103                 auquad = (unsigned Quad_t)SvIV(fromstr);
4104                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4105             }
4106             break;
4107         case 'q':
4108             while (len-- > 0) {
4109                 fromstr = NEXTFROM;
4110                 aquad = (Quad_t)SvIV(fromstr);
4111                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4112             }
4113             break;
4114 #endif /* HAS_QUAD */
4115         case 'P':
4116             len = 1;            /* assume SV is correct length */
4117             /* FALL THROUGH */
4118         case 'p':
4119             while (len-- > 0) {
4120                 fromstr = NEXTFROM;
4121                 if (fromstr == &sv_undef)
4122                     aptr = NULL;
4123                 else {
4124                     /* XXX better yet, could spirit away the string to
4125                      * a safe spot and hang on to it until the result
4126                      * of pack() (and all copies of the result) are
4127                      * gone.
4128                      */
4129                     if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4130                         warn("Attempt to pack pointer to temporary value");
4131                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4132                         aptr = SvPV(fromstr,na);
4133                     else
4134                         aptr = SvPV_force(fromstr,na);
4135                 }
4136                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4137             }
4138             break;
4139         case 'u':
4140             fromstr = NEXTFROM;
4141             aptr = SvPV(fromstr, fromlen);
4142             SvGROW(cat, fromlen * 4 / 3);
4143             if (len <= 1)
4144                 len = 45;
4145             else
4146                 len = len / 3 * 3;
4147             while (fromlen > 0) {
4148                 I32 todo;
4149
4150                 if (fromlen > len)
4151                     todo = len;
4152                 else
4153                     todo = fromlen;
4154                 doencodes(cat, aptr, todo);
4155                 fromlen -= todo;
4156                 aptr += todo;
4157             }
4158             break;
4159         }
4160     }
4161     SvSETMAGIC(cat);
4162     SP = ORIGMARK;
4163     PUSHs(cat);
4164     RETURN;
4165 }
4166 #undef NEXTFROM
4167
4168
4169 PP(pp_split)
4170 {
4171     djSP; dTARG;
4172     AV *ary;
4173     register I32 limit = POPi;                  /* note, negative is forever */
4174     SV *sv = POPs;
4175     STRLEN len;
4176     register char *s = SvPV(sv, len);
4177     char *strend = s + len;
4178     register PMOP *pm;
4179     register REGEXP *rx;
4180     register SV *dstr;
4181     register char *m;
4182     I32 iters = 0;
4183     I32 maxiters = (strend - s) + 10;
4184     I32 i;
4185     char *orig;
4186     I32 origlimit = limit;
4187     I32 realarray = 0;
4188     I32 base;
4189     AV *oldstack = curstack;
4190     I32 gimme = GIMME_V;
4191     I32 oldsave = savestack_ix;
4192     I32 make_mortal = 1;
4193     MAGIC *mg = (MAGIC *) NULL;
4194
4195 #ifdef DEBUGGING
4196     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4197 #else
4198     pm = (PMOP*)POPs;
4199 #endif
4200     if (!pm || !s)
4201         DIE("panic: do_split");
4202     rx = pm->op_pmregexp;
4203
4204     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4205              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4206
4207     if (pm->op_pmreplroot)
4208         ary = GvAVn((GV*)pm->op_pmreplroot);
4209     else if (gimme != G_ARRAY)
4210 #ifdef USE_THREADS
4211         ary = (AV*)curpad[0];
4212 #else
4213         ary = GvAVn(defgv);
4214 #endif /* USE_THREADS */
4215     else
4216         ary = Nullav;
4217     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4218         realarray = 1;
4219         PUTBACK;
4220         av_extend(ary,0);
4221         av_clear(ary);
4222         SPAGAIN;
4223         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4224             PUSHMARK(SP);
4225             XPUSHs(mg->mg_obj);
4226         }
4227         else {
4228             if (!AvREAL(ary)) {
4229                 AvREAL_on(ary);
4230                 for (i = AvFILLp(ary); i >= 0; i--)
4231                     AvARRAY(ary)[i] = &sv_undef;        /* don't free mere refs */
4232             }
4233             /* temporarily switch stacks */
4234             SWITCHSTACK(curstack, ary);
4235             make_mortal = 0;
4236         }
4237     }
4238     base = SP - stack_base;
4239     orig = s;
4240     if (pm->op_pmflags & PMf_SKIPWHITE) {
4241         if (pm->op_pmflags & PMf_LOCALE) {
4242             while (isSPACE_LC(*s))
4243                 s++;
4244         }
4245         else {
4246             while (isSPACE(*s))
4247                 s++;
4248         }
4249     }
4250     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4251         SAVEINT(multiline);
4252         multiline = pm->op_pmflags & PMf_MULTILINE;
4253     }
4254
4255     if (!limit)
4256         limit = maxiters + 2;
4257     if (pm->op_pmflags & PMf_WHITE) {
4258         while (--limit) {
4259             m = s;
4260             while (m < strend &&
4261                    !((pm->op_pmflags & PMf_LOCALE)
4262                      ? isSPACE_LC(*m) : isSPACE(*m)))
4263                 ++m;
4264             if (m >= strend)
4265                 break;
4266
4267             dstr = NEWSV(30, m-s);
4268             sv_setpvn(dstr, s, m-s);
4269             if (make_mortal)
4270                 sv_2mortal(dstr);
4271             XPUSHs(dstr);
4272
4273             s = m + 1;
4274             while (s < strend &&
4275                    ((pm->op_pmflags & PMf_LOCALE)
4276                     ? isSPACE_LC(*s) : isSPACE(*s)))
4277                 ++s;
4278         }
4279     }
4280     else if (strEQ("^", rx->precomp)) {
4281         while (--limit) {
4282             /*SUPPRESS 530*/
4283             for (m = s; m < strend && *m != '\n'; m++) ;
4284             m++;
4285             if (m >= strend)
4286                 break;
4287             dstr = NEWSV(30, m-s);
4288             sv_setpvn(dstr, s, m-s);
4289             if (make_mortal)
4290                 sv_2mortal(dstr);
4291             XPUSHs(dstr);
4292             s = m;
4293         }
4294     }
4295     else if (rx->check_substr && !rx->nparens
4296              && (rx->reganch & ROPT_CHECK_ALL)
4297              && !(rx->reganch & ROPT_ANCH)) {
4298         i = SvCUR(rx->check_substr);
4299         if (i == 1 && !SvTAIL(rx->check_substr)) {
4300             i = *SvPVX(rx->check_substr);
4301             while (--limit) {
4302                 /*SUPPRESS 530*/
4303                 for (m = s; m < strend && *m != i; m++) ;
4304                 if (m >= strend)
4305                     break;
4306                 dstr = NEWSV(30, m-s);
4307                 sv_setpvn(dstr, s, m-s);
4308                 if (make_mortal)
4309                     sv_2mortal(dstr);
4310                 XPUSHs(dstr);
4311                 s = m + 1;
4312             }
4313         }
4314         else {
4315 #ifndef lint
4316             while (s < strend && --limit &&
4317               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4318                     rx->check_substr, 0)) )
4319 #endif
4320             {
4321                 dstr = NEWSV(31, m-s);
4322                 sv_setpvn(dstr, s, m-s);
4323                 if (make_mortal)
4324                     sv_2mortal(dstr);
4325                 XPUSHs(dstr);
4326                 s = m + i;
4327             }
4328         }
4329     }
4330     else {
4331         maxiters += (strend - s) * rx->nparens;
4332         while (s < strend && --limit &&
4333                CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4334         {
4335             TAINT_IF(RX_MATCH_TAINTED(rx));
4336             if (rx->subbase
4337               && rx->subbase != orig) {
4338                 m = s;
4339                 s = orig;
4340                 orig = rx->subbase;
4341                 s = orig + (m - s);
4342                 strend = s + (strend - m);
4343             }
4344             m = rx->startp[0];
4345             dstr = NEWSV(32, m-s);
4346             sv_setpvn(dstr, s, m-s);
4347             if (make_mortal)
4348                 sv_2mortal(dstr);
4349             XPUSHs(dstr);
4350             if (rx->nparens) {
4351                 for (i = 1; i <= rx->nparens; i++) {
4352                     s = rx->startp[i];
4353                     m = rx->endp[i];
4354                     if (m && s) {
4355                         dstr = NEWSV(33, m-s);
4356                         sv_setpvn(dstr, s, m-s);
4357                     }
4358                     else
4359                         dstr = NEWSV(33, 0);
4360                     if (make_mortal)
4361                         sv_2mortal(dstr);
4362                     XPUSHs(dstr);
4363                 }
4364             }
4365             s = rx->endp[0];
4366         }
4367     }
4368
4369     LEAVE_SCOPE(oldsave);
4370     iters = (SP - stack_base) - base;
4371     if (iters > maxiters)
4372         DIE("Split loop");
4373
4374     /* keep field after final delim? */
4375     if (s < strend || (iters && origlimit)) {
4376         dstr = NEWSV(34, strend-s);
4377         sv_setpvn(dstr, s, strend-s);
4378         if (make_mortal)
4379             sv_2mortal(dstr);
4380         XPUSHs(dstr);
4381         iters++;
4382     }
4383     else if (!origlimit) {
4384         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4385             iters--, SP--;
4386     }
4387
4388     if (realarray) {
4389         if (!mg) {
4390             SWITCHSTACK(ary, oldstack);
4391             if (SvSMAGICAL(ary)) {
4392                 PUTBACK;
4393                 mg_set((SV*)ary);
4394                 SPAGAIN;
4395             }
4396             if (gimme == G_ARRAY) {
4397                 EXTEND(SP, iters);
4398                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4399                 SP += iters;
4400                 RETURN;
4401             }
4402         }
4403         else {
4404             PUTBACK;
4405             ENTER;
4406             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4407             LEAVE;
4408             SPAGAIN;
4409             if (gimme == G_ARRAY) {
4410                 /* EXTEND should not be needed - we just popped them */
4411                 EXTEND(SP, iters);
4412                 for (i=0; i < iters; i++) {
4413                     SV **svp = av_fetch(ary, i, FALSE);
4414                     PUSHs((svp) ? *svp : &sv_undef);
4415                 }
4416                 RETURN;
4417             }
4418         }
4419     }
4420     else {
4421         if (gimme == G_ARRAY)
4422             RETURN;
4423     }
4424     if (iters || !pm->op_pmreplroot) {
4425         GETTARGET;
4426         PUSHi(iters);
4427         RETURN;
4428     }
4429     RETPUSHUNDEF;
4430 }
4431
4432 #ifdef USE_THREADS
4433 void
4434 unlock_condpair(void *svv)
4435 {
4436     dTHR;
4437     MAGIC *mg = mg_find((SV*)svv, 'm');
4438
4439     if (!mg)
4440         croak("panic: unlock_condpair unlocking non-mutex");
4441     MUTEX_LOCK(MgMUTEXP(mg));
4442     if (MgOWNER(mg) != thr)
4443         croak("panic: unlock_condpair unlocking mutex that we don't own");
4444     MgOWNER(mg) = 0;
4445     COND_SIGNAL(MgOWNERCONDP(mg));
4446     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4447                           (unsigned long)thr, (unsigned long)svv);)
4448     MUTEX_UNLOCK(MgMUTEXP(mg));
4449 }
4450 #endif /* USE_THREADS */
4451
4452 PP(pp_lock)
4453 {
4454     djSP;
4455     dTOPss;
4456     SV *retsv = sv;
4457 #ifdef USE_THREADS
4458     MAGIC *mg;
4459
4460     if (SvROK(sv))
4461         sv = SvRV(sv);
4462
4463     mg = condpair_magic(sv);
4464     MUTEX_LOCK(MgMUTEXP(mg));
4465     if (MgOWNER(mg) == thr)
4466         MUTEX_UNLOCK(MgMUTEXP(mg));
4467     else {
4468         while (MgOWNER(mg))
4469             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4470         MgOWNER(mg) = thr;
4471         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4472                               (unsigned long)thr, (unsigned long)sv);)
4473         MUTEX_UNLOCK(MgMUTEXP(mg));
4474         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4475         save_destructor(unlock_condpair, sv);
4476     }
4477 #endif /* USE_THREADS */
4478     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4479         || SvTYPE(retsv) == SVt_PVCV) {
4480         retsv = refto(retsv);
4481     }
4482     SETs(retsv);
4483     RETURN;
4484 }
4485
4486 PP(pp_threadsv)
4487 {
4488     djSP;
4489 #ifdef USE_THREADS
4490     EXTEND(SP, 1);
4491     if (op->op_private & OPpLVAL_INTRO)
4492         PUSHs(*save_threadsv(op->op_targ));
4493     else
4494         PUSHs(THREADSV(op->op_targ));
4495     RETURN;
4496 #else
4497     DIE("tried to access per-thread data in non-threaded perl");
4498 #endif /* USE_THREADS */
4499 }