pp.c

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