pp.c

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