pp.c

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