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