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