pp.c

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