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