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