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