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