pp.c

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