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