pp.c

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