pp.c

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