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