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