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