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