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