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