pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (c) 1991-1997, 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  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  20  * seems to show up when compiling pp.c - it generates the wrong double
  21  * precision constant value for (double)UV_MAX when used inline in the body
  22  * of the code below, so this makes a static variable up front (which the
  23  * compiler seems to get correct) and uses it in place of UV_MAX below.
  24  */
  25 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  26 static double UV_MAX_cxux = ((double)UV_MAX);
  27 #endif
  28
  29 /*
  30  * Types used in bitwise operations.
  31  *
  32  * Normally we'd just use IV and UV.  However, some hardware and
  33  * software combinations (e.g. Alpha and current OSF/1) don't have a
  34  * floating-point type to use for NV that has adequate bits to fully
  35  * hold an IV/UV.  (In other words, sizeof(long) == sizeof(double).)
  36  *
  37  * It just so happens that "int" is the right size almost everywhere.
  38  */
  39 typedef int IBW;
  40 typedef unsigned UBW;
  41
  42 /*
  43  * Mask used after bitwise operations.
  44  *
  45  * There is at least one realm (Cray word machines) that doesn't
  46  * have an integral type (except char) small enough to be represented
  47  * in a double without loss; that is, it has no 32-bit type.
  48  */
  49 #if LONGSIZE > 4  && defined(_CRAY) && !defined(_CRAYMPP)
  50 #  define BW_BITS  32
  51 #  define BW_MASK  ((1 << BW_BITS) - 1)
  52 #  define BW_SIGN  (1 << (BW_BITS - 1))
  53 #  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
  54 #  define BWu(u)  ((u) & BW_MASK)
  55 #else
  56 #  define BWi(i)  (i)
  57 #  define BWu(u)  (u)
  58 #endif
  59
  60 /*
  61  * Offset for integer pack/unpack.
  62  *
  63  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  64  * which for now are all Crays, pack and unpack have to play games.
  65  */
  66
  67 /*
  68  * These values are required for portability of pack() output.
  69  * If they're not right on your machine, then pack() and unpack()
  70  * wouldn't work right anyway; you'll need to apply the Cray hack.
  71  * (I'd like to check them with #if, but you can't use sizeof() in
  72  * the preprocessor.)  --???
  73  */
  74 /*
  75     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  76     defines are now in config.h.  --Andy Dougherty  April 1998
  77  */
  78 #define SIZE16 2
  79 #define SIZE32 4
  80
  81 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  82 #   define PERL_NATINT_PACK
  83 #endif
  84
  85 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
  86 #  if BYTEORDER == 0x12345678
  87 #    define OFF16(p)    (char*)(p)
  88 #    define OFF32(p)    (char*)(p)
  89 #  else
  90 #    if BYTEORDER == 0x87654321
  91 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  92 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  93 #    else
  94        }}}} bad cray byte order
  95 #    endif
  96 #  endif
  97 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  98 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  99 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
 100 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
 101 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
 102 #else
 103 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
 104 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
 105 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
 106 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
 107 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
 108 #endif
 109
 110 #ifndef PERL_OBJECT
 111 static void doencodes _((SV* sv, char* s, I32 len));
 112 static SV* refto _((SV* sv));
 113 static U32 seed _((void));
 114 #endif
 115
 116 /* variations on pp_null */
 117
 118 #ifdef I_UNISTD
 119 #include <unistd.h>
 120 #endif
 121
 122 /* XXX I can't imagine anyone who doesn't have this actually _needs_
 123    it, since pid_t is an integral type.
 124    --AD  2/20/1998
 125 */
 126 #ifdef NEED_GETPID_PROTO
 127 extern Pid_t getpid (void);
 128 #endif
 129
 130 PP(pp_stub)
 131 {
 132     djSP;
 133     if (GIMME_V == G_SCALAR)
 134         XPUSHs(&PL_sv_undef);
 135     RETURN;
 136 }
 137
 138 PP(pp_scalar)
 139 {
 140     return NORMAL;
 141 }
 142
 143 /* Pushy stuff. */
 144
 145 PP(pp_padav)
 146 {
 147     djSP; dTARGET;
 148     if (PL_op->op_private & OPpLVAL_INTRO)
 149         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 150     EXTEND(SP, 1);
 151     if (PL_op->op_flags & OPf_REF) {
 152         PUSHs(TARG);
 153         RETURN;
 154     }
 155     if (GIMME == G_ARRAY) {
 156         I32 maxarg = AvFILL((AV*)TARG) + 1;
 157         EXTEND(SP, maxarg);
 158         if (SvMAGICAL(TARG)) {
 159             U32 i;
 160             for (i=0; i < maxarg; i++) {
 161                 SV **svp = av_fetch((AV*)TARG, i, FALSE);
 162                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 163             }
 164         }
 165         else {
 166             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
 167         }
 168         SP += maxarg;
 169     }
 170     else {
 171         SV* sv = sv_newmortal();
 172         I32 maxarg = AvFILL((AV*)TARG) + 1;
 173         sv_setiv(sv, maxarg);
 174         PUSHs(sv);
 175     }
 176     RETURN;
 177 }
 178
 179 PP(pp_padhv)
 180 {
 181     djSP; dTARGET;
 182     I32 gimme;
 183
 184     XPUSHs(TARG);
 185     if (PL_op->op_private & OPpLVAL_INTRO)
 186         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 187     if (PL_op->op_flags & OPf_REF)
 188         RETURN;
 189     gimme = GIMME_V;
 190     if (gimme == G_ARRAY) {
 191         RETURNOP(do_kv(ARGS));
 192     }
 193     else if (gimme == G_SCALAR) {
 194         SV* sv = sv_newmortal();
 195         if (HvFILL((HV*)TARG))
 196             sv_setpvf(sv, "%ld/%ld",
 197                       (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
 198         else
 199             sv_setiv(sv, 0);
 200         SETs(sv);
 201     }
 202     RETURN;
 203 }
 204
 205 PP(pp_padany)
 206 {
 207     DIE("NOT IMPL LINE %d",__LINE__);
 208 }
 209
 210 /* Translations. */
 211
 212 PP(pp_rv2gv)
 213 {
 214     djSP; dTOPss;
 215
 216     if (SvROK(sv)) {
 217       wasref:
 218         tryAMAGICunDEREF(to_gv);
 219
 220         sv = SvRV(sv);
 221         if (SvTYPE(sv) == SVt_PVIO) {
 222             GV *gv = (GV*) sv_newmortal();
 223             gv_init(gv, 0, "", 0, 0);
 224             GvIOp(gv) = (IO *)sv;
 225             (void)SvREFCNT_inc(sv);
 226             sv = (SV*) gv;
 227         }
 228         else if (SvTYPE(sv) != SVt_PVGV)
 229             DIE("Not a GLOB reference");
 230     }
 231     else {
 232         if (SvTYPE(sv) != SVt_PVGV) {
 233             char *sym;
 234             STRLEN n_a;
 235
 236             if (SvGMAGICAL(sv)) {
 237                 mg_get(sv);
 238                 if (SvROK(sv))
 239                     goto wasref;
 240             }
 241             if (!SvOK(sv)) {
 242                 if (PL_op->op_flags & OPf_REF ||
 243                     PL_op->op_private & HINT_STRICT_REFS)
 244                     DIE(PL_no_usym, "a symbol");
 245                 if (ckWARN(WARN_UNINITIALIZED))
 246                     warner(WARN_UNINITIALIZED, PL_warn_uninit);
 247                 RETSETUNDEF;
 248             }
 249             sym = SvPV(sv, n_a);
 250             if ((PL_op->op_flags & OPf_SPECIAL) &&
 251                 !(PL_op->op_flags & OPf_MOD))
 252             {
 253                 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
 254                 if (!sv)
 255                     RETSETUNDEF;
 256             }
 257             else {
 258                 if (PL_op->op_private & HINT_STRICT_REFS)
 259                     DIE(PL_no_symref, sym, "a symbol");
 260                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
 261             }
 262         }
 263     }
 264     if (PL_op->op_private & OPpLVAL_INTRO)
 265         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 266     SETs(sv);
 267     RETURN;
 268 }
 269
 270 PP(pp_rv2sv)
 271 {
 272     djSP; dTOPss;
 273
 274     if (SvROK(sv)) {
 275       wasref:
 276         tryAMAGICunDEREF(to_sv);
 277
 278         sv = SvRV(sv);
 279         switch (SvTYPE(sv)) {
 280         case SVt_PVAV:
 281         case SVt_PVHV:
 282         case SVt_PVCV:
 283             DIE("Not a SCALAR reference");
 284         }
 285     }
 286     else {
 287         GV *gv = (GV*)sv;
 288         char *sym;
 289         STRLEN n_a;
 290
 291         if (SvTYPE(gv) != SVt_PVGV) {
 292             if (SvGMAGICAL(sv)) {
 293                 mg_get(sv);
 294                 if (SvROK(sv))
 295                     goto wasref;
 296             }
 297             if (!SvOK(sv)) {
 298                 if (PL_op->op_flags & OPf_REF ||
 299                     PL_op->op_private & HINT_STRICT_REFS)
 300                     DIE(PL_no_usym, "a SCALAR");
 301                 if (ckWARN(WARN_UNINITIALIZED))
 302                     warner(WARN_UNINITIALIZED, PL_warn_uninit);
 303                 RETSETUNDEF;
 304             }
 305             sym = SvPV(sv, n_a);
 306             if ((PL_op->op_flags & OPf_SPECIAL) &&
 307                 !(PL_op->op_flags & OPf_MOD))
 308             {
 309                 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
 310                 if (!gv)
 311                     RETSETUNDEF;
 312             }
 313             else {
 314                 if (PL_op->op_private & HINT_STRICT_REFS)
 315                     DIE(PL_no_symref, sym, "a SCALAR");
 316                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
 317             }
 318         }
 319         sv = GvSV(gv);
 320     }
 321     if (PL_op->op_flags & OPf_MOD) {
 322         if (PL_op->op_private & OPpLVAL_INTRO)
 323             sv = save_scalar((GV*)TOPs);
 324         else if (PL_op->op_private & OPpDEREF)
 325             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 326     }
 327     SETs(sv);
 328     RETURN;
 329 }
 330
 331 PP(pp_av2arylen)
 332 {
 333     djSP;
 334     AV *av = (AV*)TOPs;
 335     SV *sv = AvARYLEN(av);
 336     if (!sv) {
 337         AvARYLEN(av) = sv = NEWSV(0,0);
 338         sv_upgrade(sv, SVt_IV);
 339         sv_magic(sv, (SV*)av, '#', Nullch, 0);
 340     }
 341     SETs(sv);
 342     RETURN;
 343 }
 344
 345 PP(pp_pos)
 346 {
 347     djSP; dTARGET; dPOPss;
 348
 349     if (PL_op->op_flags & OPf_MOD) {
 350         if (SvTYPE(TARG) < SVt_PVLV) {
 351             sv_upgrade(TARG, SVt_PVLV);
 352             sv_magic(TARG, Nullsv, '.', Nullch, 0);
 353         }
 354
 355         LvTYPE(TARG) = '.';
 356         if (LvTARG(TARG) != sv) {
 357             if (LvTARG(TARG))
 358                 SvREFCNT_dec(LvTARG(TARG));
 359             LvTARG(TARG) = SvREFCNT_inc(sv);
 360         }
 361         PUSHs(TARG);    /* no SvSETMAGIC */
 362         RETURN;
 363     }
 364     else {
 365         MAGIC* mg;
 366
 367         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 368             mg = mg_find(sv, 'g');
 369             if (mg && mg->mg_len >= 0) {
 370                 I32 i = mg->mg_len;
 371                 if (IN_UTF8)
 372                     sv_pos_b2u(sv, &i);
 373                 PUSHi(i + PL_curcop->cop_arybase);
 374                 RETURN;
 375             }
 376         }
 377         RETPUSHUNDEF;
 378     }
 379 }
 380
 381 PP(pp_rv2cv)
 382 {
 383     djSP;
 384     GV *gv;
 385     HV *stash;
 386
 387     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 388     /* (But not in defined().) */
 389     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
 390     if (cv) {
 391         if (CvCLONE(cv))
 392             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 393     }
 394     else
 395         cv = (CV*)&PL_sv_undef;
 396     SETs((SV*)cv);
 397     RETURN;
 398 }
 399
 400 PP(pp_prototype)
 401 {
 402     djSP;
 403     CV *cv;
 404     HV *stash;
 405     GV *gv;
 406     SV *ret;
 407
 408     ret = &PL_sv_undef;
 409     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 410         char *s = SvPVX(TOPs);
 411         if (strnEQ(s, "CORE::", 6)) {
 412             int code;
 413
 414             code = keyword(s + 6, SvCUR(TOPs) - 6);
 415             if (code < 0) {     /* Overridable. */
 416 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 417                 int i = 0, n = 0, seen_question = 0;
 418                 I32 oa;
 419                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 420
 421                 while (i < MAXO) {      /* The slow way. */
 422                     if (strEQ(s + 6, PL_op_name[i])
 423                         || strEQ(s + 6, PL_op_desc[i]))
 424                     {
 425                         goto found;
 426                     }
 427                     i++;
 428                 }
 429                 goto nonesuch;          /* Should not happen... */
 430               found:
 431                 oa = PL_opargs[i] >> OASHIFT;
 432                 while (oa) {
 433                     if (oa & OA_OPTIONAL) {
 434                         seen_question = 1;
 435                         str[n++] = ';';
 436                     }
 437                     else if (seen_question)
 438                         goto set;       /* XXXX system, exec */
 439                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 440                         && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
 441                         str[n++] = '\\';
 442                     }
 443                     /* What to do with R ((un)tie, tied, (sys)read, recv)? */
 444                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 445                     oa = oa >> 4;
 446                 }
 447                 str[n++] = '\0';
 448                 ret = sv_2mortal(newSVpv(str, n - 1));
 449             }
 450             else if (code)              /* Non-Overridable */
 451                 goto set;
 452             else {                      /* None such */
 453               nonesuch:
 454                 croak("Cannot find an opnumber for \"%s\"", s+6);
 455             }
 456         }
 457     }
 458     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 459     if (cv && SvPOK(cv))
 460         ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
 461   set:
 462     SETs(ret);
 463     RETURN;
 464 }
 465
 466 PP(pp_anoncode)
 467 {
 468     djSP;
 469     CV* cv = (CV*)PL_curpad[PL_op->op_targ];
 470     if (CvCLONE(cv))
 471         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 472     EXTEND(SP,1);
 473     PUSHs((SV*)cv);
 474     RETURN;
 475 }
 476
 477 PP(pp_srefgen)
 478 {
 479     djSP;
 480     *SP = refto(*SP);
 481     RETURN;
 482 }
 483
 484 PP(pp_refgen)
 485 {
 486     djSP; dMARK;
 487     if (GIMME != G_ARRAY) {
 488         if (++MARK <= SP)
 489             *MARK = *SP;
 490         else
 491             *MARK = &PL_sv_undef;
 492         *MARK = refto(*MARK);
 493         SP = MARK;
 494         RETURN;
 495     }
 496     EXTEND_MORTAL(SP - MARK);
 497     while (++MARK <= SP)
 498         *MARK = refto(*MARK);
 499     RETURN;
 500 }
 501
 502 STATIC SV*
 503 refto(SV *sv)
 504 {
 505     SV* rv;
 506
 507     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 508         if (LvTARGLEN(sv))
 509             vivify_defelem(sv);
 510         if (!(sv = LvTARG(sv)))
 511             sv = &PL_sv_undef;
 512     }
 513     else if (SvPADTMP(sv))
 514         sv = newSVsv(sv);
 515     else {
 516         SvTEMP_off(sv);
 517         (void)SvREFCNT_inc(sv);
 518     }
 519     rv = sv_newmortal();
 520     sv_upgrade(rv, SVt_RV);
 521     SvRV(rv) = sv;
 522     SvROK_on(rv);
 523     return rv;
 524 }
 525
 526 PP(pp_ref)
 527 {
 528     djSP; dTARGET;
 529     SV *sv;
 530     char *pv;
 531
 532     sv = POPs;
 533
 534     if (sv && SvGMAGICAL(sv))
 535         mg_get(sv);
 536
 537     if (!sv || !SvROK(sv))
 538         RETPUSHNO;
 539
 540     sv = SvRV(sv);
 541     pv = sv_reftype(sv,TRUE);
 542     PUSHp(pv, strlen(pv));
 543     RETURN;
 544 }
 545
 546 PP(pp_bless)
 547 {
 548     djSP;
 549     HV *stash;
 550
 551     if (MAXARG == 1)
 552         stash = PL_curcop->cop_stash;
 553     else {
 554         SV *ssv = POPs;
 555         STRLEN len;
 556         char *ptr = SvPV(ssv,len);
 557         if (ckWARN(WARN_UNSAFE) && len == 0)
 558             warner(WARN_UNSAFE,
 559                    "Explicit blessing to '' (assuming package main)");
 560         stash = gv_stashpvn(ptr, len, TRUE);
 561     }
 562
 563     (void)sv_bless(TOPs, stash);
 564     RETURN;
 565 }
 566
 567 PP(pp_gelem)
 568 {
 569     GV *gv;
 570     SV *sv;
 571     SV *tmpRef;
 572     char *elem;
 573     djSP;
 574     STRLEN n_a;
 575
 576     sv = POPs;
 577     elem = SvPV(sv, n_a);
 578     gv = (GV*)POPs;
 579     tmpRef = Nullsv;
 580     sv = Nullsv;
 581     switch (elem ? *elem : '\0')
 582     {
 583     case 'A':
 584         if (strEQ(elem, "ARRAY"))
 585             tmpRef = (SV*)GvAV(gv);
 586         break;
 587     case 'C':
 588         if (strEQ(elem, "CODE"))
 589             tmpRef = (SV*)GvCVu(gv);
 590         break;
 591     case 'F':
 592         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 593             tmpRef = (SV*)GvIOp(gv);
 594         break;
 595     case 'G':
 596         if (strEQ(elem, "GLOB"))
 597             tmpRef = (SV*)gv;
 598         break;
 599     case 'H':
 600         if (strEQ(elem, "HASH"))
 601             tmpRef = (SV*)GvHV(gv);
 602         break;
 603     case 'I':
 604         if (strEQ(elem, "IO"))
 605             tmpRef = (SV*)GvIOp(gv);
 606         break;
 607     case 'N':
 608         if (strEQ(elem, "NAME"))
 609             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
 610         break;
 611     case 'P':
 612         if (strEQ(elem, "PACKAGE"))
 613             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 614         break;
 615     case 'S':
 616         if (strEQ(elem, "SCALAR"))
 617             tmpRef = GvSV(gv);
 618         break;
 619     }
 620     if (tmpRef)
 621         sv = newRV(tmpRef);
 622     if (sv)
 623         sv_2mortal(sv);
 624     else
 625         sv = &PL_sv_undef;
 626     XPUSHs(sv);
 627     RETURN;
 628 }
 629
 630 /* Pattern matching */
 631
 632 PP(pp_study)
 633 {
 634     djSP; dPOPss;
 635     register UNOP *unop = cUNOP;
 636     register unsigned char *s;
 637     register I32 pos;
 638     register I32 ch;
 639     register I32 *sfirst;
 640     register I32 *snext;
 641     STRLEN len;
 642
 643     if (sv == PL_lastscream) {
 644         if (SvSCREAM(sv))
 645             RETPUSHYES;
 646     }
 647     else {
 648         if (PL_lastscream) {
 649             SvSCREAM_off(PL_lastscream);
 650             SvREFCNT_dec(PL_lastscream);
 651         }
 652         PL_lastscream = SvREFCNT_inc(sv);
 653     }
 654
 655     s = (unsigned char*)(SvPV(sv, len));
 656     pos = len;
 657     if (pos <= 0)
 658         RETPUSHNO;
 659     if (pos > PL_maxscream) {
 660         if (PL_maxscream < 0) {
 661             PL_maxscream = pos + 80;
 662             New(301, PL_screamfirst, 256, I32);
 663             New(302, PL_screamnext, PL_maxscream, I32);
 664         }
 665         else {
 666             PL_maxscream = pos + pos / 4;
 667             Renew(PL_screamnext, PL_maxscream, I32);
 668         }
 669     }
 670
 671     sfirst = PL_screamfirst;
 672     snext = PL_screamnext;
 673
 674     if (!sfirst || !snext)
 675         DIE("do_study: out of memory");
 676
 677     for (ch = 256; ch; --ch)
 678         *sfirst++ = -1;
 679     sfirst -= 256;
 680
 681     while (--pos >= 0) {
 682         ch = s[pos];
 683         if (sfirst[ch] >= 0)
 684             snext[pos] = sfirst[ch] - pos;
 685         else
 686             snext[pos] = -pos;
 687         sfirst[ch] = pos;
 688     }
 689
 690     SvSCREAM_on(sv);
 691     sv_magic(sv, Nullsv, 'g', Nullch, 0);       /* piggyback on m//g magic */
 692     RETPUSHYES;
 693 }
 694
 695 PP(pp_trans)
 696 {
 697     djSP; dTARG;
 698     SV *sv;
 699
 700     if (PL_op->op_flags & OPf_STACKED)
 701         sv = POPs;
 702     else {
 703         sv = DEFSV;
 704         EXTEND(SP,1);
 705     }
 706     TARG = sv_newmortal();
 707     PUSHi(do_trans(sv));
 708     RETURN;
 709 }
 710
 711 /* Lvalue operators. */
 712
 713 PP(pp_schop)
 714 {
 715     djSP; dTARGET;
 716     do_chop(TARG, TOPs);
 717     SETTARG;
 718     RETURN;
 719 }
 720
 721 PP(pp_chop)
 722 {
 723     djSP; dMARK; dTARGET;
 724     while (SP > MARK)
 725         do_chop(TARG, POPs);
 726     PUSHTARG;
 727     RETURN;
 728 }
 729
 730 PP(pp_schomp)
 731 {
 732     djSP; dTARGET;
 733     SETi(do_chomp(TOPs));
 734     RETURN;
 735 }
 736
 737 PP(pp_chomp)
 738 {
 739     djSP; dMARK; dTARGET;
 740     register I32 count = 0;
 741
 742     while (SP > MARK)
 743         count += do_chomp(POPs);
 744     PUSHi(count);
 745     RETURN;
 746 }
 747
 748 PP(pp_defined)
 749 {
 750     djSP;
 751     register SV* sv;
 752
 753     sv = POPs;
 754     if (!sv || !SvANY(sv))
 755         RETPUSHNO;
 756     switch (SvTYPE(sv)) {
 757     case SVt_PVAV:
 758         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 759             RETPUSHYES;
 760         break;
 761     case SVt_PVHV:
 762         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 763             RETPUSHYES;
 764         break;
 765     case SVt_PVCV:
 766         if (CvROOT(sv) || CvXSUB(sv))
 767             RETPUSHYES;
 768         break;
 769     default:
 770         if (SvGMAGICAL(sv))
 771             mg_get(sv);
 772         if (SvOK(sv))
 773             RETPUSHYES;
 774     }
 775     RETPUSHNO;
 776 }
 777
 778 PP(pp_undef)
 779 {
 780     djSP;
 781     SV *sv;
 782
 783     if (!PL_op->op_private) {
 784         EXTEND(SP, 1);
 785         RETPUSHUNDEF;
 786     }
 787
 788     sv = POPs;
 789     if (!sv)
 790         RETPUSHUNDEF;
 791
 792     if (SvTHINKFIRST(sv)) {
 793         if (SvREADONLY(sv)) {
 794             dTHR;
 795             if (PL_curcop != &PL_compiling)
 796                 croak(PL_no_modify);
 797         }
 798         if (SvROK(sv))
 799             sv_unref(sv);
 800     }
 801
 802     switch (SvTYPE(sv)) {
 803     case SVt_NULL:
 804         break;
 805     case SVt_PVAV:
 806         av_undef((AV*)sv);
 807         break;
 808     case SVt_PVHV:
 809         hv_undef((HV*)sv);
 810         break;
 811     case SVt_PVCV:
 812         if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
 813             warner(WARN_UNSAFE, "Constant subroutine %s undefined",
 814                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 815         /* FALL THROUGH */
 816     case SVt_PVFM:
 817         { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
 818           cv_undef((CV*)sv);
 819           CvGV((CV*)sv) = gv; }   /* let user-undef'd sub keep its identity */
 820         break;
 821     case SVt_PVGV:
 822         if (SvFAKE(sv))
 823             SvSetMagicSV(sv, &PL_sv_undef);
 824         else {
 825             GP *gp;
 826             gp_free((GV*)sv);
 827             Newz(602, gp, 1, GP);
 828             GvGP(sv) = gp_ref(gp);
 829             GvSV(sv) = NEWSV(72,0);
 830             GvLINE(sv) = PL_curcop->cop_line;
 831             GvEGV(sv) = (GV*)sv;
 832             GvMULTI_on(sv);
 833         }
 834         break;
 835     default:
 836         if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
 837             (void)SvOOK_off(sv);
 838             Safefree(SvPVX(sv));
 839             SvPV_set(sv, Nullch);
 840             SvLEN_set(sv, 0);
 841         }
 842         (void)SvOK_off(sv);
 843         SvSETMAGIC(sv);
 844     }
 845
 846     RETPUSHUNDEF;
 847 }
 848
 849 PP(pp_predec)
 850 {
 851     djSP;
 852     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 853         croak(PL_no_modify);
 854     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 855         SvIVX(TOPs) != IV_MIN)
 856     {
 857         --SvIVX(TOPs);
 858         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 859     }
 860     else
 861         sv_dec(TOPs);
 862     SvSETMAGIC(TOPs);
 863     return NORMAL;
 864 }
 865
 866 PP(pp_postinc)
 867 {
 868     djSP; dTARGET;
 869     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 870         croak(PL_no_modify);
 871     sv_setsv(TARG, TOPs);
 872     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 873         SvIVX(TOPs) != IV_MAX)
 874     {
 875         ++SvIVX(TOPs);
 876         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 877     }
 878     else
 879         sv_inc(TOPs);
 880     SvSETMAGIC(TOPs);
 881     if (!SvOK(TARG))
 882         sv_setiv(TARG, 0);
 883     SETs(TARG);
 884     return NORMAL;
 885 }
 886
 887 PP(pp_postdec)
 888 {
 889     djSP; dTARGET;
 890     if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 891         croak(PL_no_modify);
 892     sv_setsv(TARG, TOPs);
 893     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 894         SvIVX(TOPs) != IV_MIN)
 895     {
 896         --SvIVX(TOPs);
 897         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 898     }
 899     else
 900         sv_dec(TOPs);
 901     SvSETMAGIC(TOPs);
 902     SETs(TARG);
 903     return NORMAL;
 904 }
 905
 906 /* Ordinary operators. */
 907
 908 PP(pp_pow)
 909 {
 910     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
 911     {
 912       dPOPTOPnnrl;
 913       SETn( pow( left, right) );
 914       RETURN;
 915     }
 916 }
 917
 918 PP(pp_multiply)
 919 {
 920     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
 921     {
 922       dPOPTOPnnrl;
 923       SETn( left * right );
 924       RETURN;
 925     }
 926 }
 927
 928 PP(pp_divide)
 929 {
 930     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
 931     {
 932       dPOPPOPnnrl;
 933       double value;
 934       if (right == 0.0)
 935         DIE("Illegal division by zero");
 936 #ifdef SLOPPYDIVIDE
 937       /* insure that 20./5. == 4. */
 938       {
 939         IV k;
 940         if ((double)I_V(left)  == left &&
 941             (double)I_V(right) == right &&
 942             (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
 943             value = k;
 944         }
 945         else {
 946             value = left / right;
 947         }
 948       }
 949 #else
 950       value = left / right;
 951 #endif
 952       PUSHn( value );
 953       RETURN;
 954     }
 955 }
 956
 957 PP(pp_modulo)
 958 {
 959     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
 960     {
 961       UV left;
 962       UV right;
 963       bool left_neg;
 964       bool right_neg;
 965       UV ans;
 966
 967       if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 968         IV i = SvIVX(POPs);
 969         right = (right_neg = (i < 0)) ? -i : i;
 970       }
 971       else {
 972         double n = POPn;
 973         right = U_V((right_neg = (n < 0)) ? -n : n);
 974       }
 975
 976       if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 977         IV i = SvIVX(POPs);
 978         left = (left_neg = (i < 0)) ? -i : i;
 979       }
 980       else {
 981         double n = POPn;
 982         left = U_V((left_neg = (n < 0)) ? -n : n);
 983       }
 984
 985       if (!right)
 986         DIE("Illegal modulus zero");
 987
 988       ans = left % right;
 989       if ((left_neg != right_neg) && ans)
 990         ans = right - ans;
 991       if (right_neg) {
 992         /* XXX may warn: unary minus operator applied to unsigned type */
 993         /* could change -foo to be (~foo)+1 instead     */
 994         if (ans <= ~((UV)IV_MAX)+1)
 995           sv_setiv(TARG, ~ans+1);
 996         else
 997           sv_setnv(TARG, -(double)ans);
 998       }
 999       else
1000         sv_setuv(TARG, ans);
1001       PUSHTARG;
1002       RETURN;
1003     }
1004 }
1005
1006 PP(pp_repeat)
1007 {
1008   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1009   {
1010     register I32 count = POPi;
1011     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1012         dMARK;
1013         I32 items = SP - MARK;
1014         I32 max;
1015
1016         max = items * count;
1017         MEXTEND(MARK, max);
1018         if (count > 1) {
1019             while (SP > MARK) {
1020                 if (*SP)
1021                     SvTEMP_off((*SP));
1022                 SP--;
1023             }
1024             MARK++;
1025             repeatcpy((char*)(MARK + items), (char*)MARK,
1026                 items * sizeof(SV*), count - 1);
1027             SP += max;
1028         }
1029         else if (count <= 0)
1030             SP -= items;
1031     }
1032     else {      /* Note: mark already snarfed by pp_list */
1033         SV *tmpstr;
1034         STRLEN len;
1035
1036         tmpstr = POPs;
1037         if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1038             if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1039                 DIE("Can't x= to readonly value");
1040             if (SvROK(tmpstr))
1041                 sv_unref(tmpstr);
1042         }
1043         SvSetSV(TARG, tmpstr);
1044         SvPV_force(TARG, len);
1045         if (count != 1) {
1046             if (count < 1)
1047                 SvCUR_set(TARG, 0);
1048             else {
1049                 SvGROW(TARG, (count * len) + 1);
1050                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1051                 SvCUR(TARG) *= count;
1052             }
1053             *SvEND(TARG) = '\0';
1054         }
1055         (void)SvPOK_only(TARG);
1056         PUSHTARG;
1057     }
1058     RETURN;
1059   }
1060 }
1061
1062 PP(pp_subtract)
1063 {
1064     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1065     {
1066       dPOPTOPnnrl_ul;
1067       SETn( left - right );
1068       RETURN;
1069     }
1070 }
1071
1072 PP(pp_left_shift)
1073 {
1074     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1075     {
1076       IBW shift = POPi;
1077       if (PL_op->op_private & HINT_INTEGER) {
1078         IBW i = TOPi;
1079         i = BWi(i) << shift;
1080         SETi(BWi(i));
1081       }
1082       else {
1083         UBW u = TOPu;
1084         u <<= shift;
1085         SETu(BWu(u));
1086       }
1087       RETURN;
1088     }
1089 }
1090
1091 PP(pp_right_shift)
1092 {
1093     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1094     {
1095       IBW shift = POPi;
1096       if (PL_op->op_private & HINT_INTEGER) {
1097         IBW i = TOPi;
1098         i = BWi(i) >> shift;
1099         SETi(BWi(i));
1100       }
1101       else {
1102         UBW u = TOPu;
1103         u >>= shift;
1104         SETu(BWu(u));
1105       }
1106       RETURN;
1107     }
1108 }
1109
1110 PP(pp_lt)
1111 {
1112     djSP; tryAMAGICbinSET(lt,0);
1113     {
1114       dPOPnv;
1115       SETs(boolSV(TOPn < value));
1116       RETURN;
1117     }
1118 }
1119
1120 PP(pp_gt)
1121 {
1122     djSP; tryAMAGICbinSET(gt,0);
1123     {
1124       dPOPnv;
1125       SETs(boolSV(TOPn > value));
1126       RETURN;
1127     }
1128 }
1129
1130 PP(pp_le)
1131 {
1132     djSP; tryAMAGICbinSET(le,0);
1133     {
1134       dPOPnv;
1135       SETs(boolSV(TOPn <= value));
1136       RETURN;
1137     }
1138 }
1139
1140 PP(pp_ge)
1141 {
1142     djSP; tryAMAGICbinSET(ge,0);
1143     {
1144       dPOPnv;
1145       SETs(boolSV(TOPn >= value));
1146       RETURN;
1147     }
1148 }
1149
1150 PP(pp_ne)
1151 {
1152     djSP; tryAMAGICbinSET(ne,0);
1153     {
1154       dPOPnv;
1155       SETs(boolSV(TOPn != value));
1156       RETURN;
1157     }
1158 }
1159
1160 PP(pp_ncmp)
1161 {
1162     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1163     {
1164       dPOPTOPnnrl;
1165       I32 value;
1166
1167       if (left == right)
1168         value = 0;
1169       else if (left < right)
1170         value = -1;
1171       else if (left > right)
1172         value = 1;
1173       else {
1174         SETs(&PL_sv_undef);
1175         RETURN;
1176       }
1177       SETi(value);
1178       RETURN;
1179     }
1180 }
1181
1182 PP(pp_slt)
1183 {
1184     djSP; tryAMAGICbinSET(slt,0);
1185     {
1186       dPOPTOPssrl;
1187       int cmp = ((PL_op->op_private & OPpLOCALE)
1188                  ? sv_cmp_locale(left, right)
1189                  : sv_cmp(left, right));
1190       SETs(boolSV(cmp < 0));
1191       RETURN;
1192     }
1193 }
1194
1195 PP(pp_sgt)
1196 {
1197     djSP; tryAMAGICbinSET(sgt,0);
1198     {
1199       dPOPTOPssrl;
1200       int cmp = ((PL_op->op_private & OPpLOCALE)
1201                  ? sv_cmp_locale(left, right)
1202                  : sv_cmp(left, right));
1203       SETs(boolSV(cmp > 0));
1204       RETURN;
1205     }
1206 }
1207
1208 PP(pp_sle)
1209 {
1210     djSP; tryAMAGICbinSET(sle,0);
1211     {
1212       dPOPTOPssrl;
1213       int cmp = ((PL_op->op_private & OPpLOCALE)
1214                  ? sv_cmp_locale(left, right)
1215                  : sv_cmp(left, right));
1216       SETs(boolSV(cmp <= 0));
1217       RETURN;
1218     }
1219 }
1220
1221 PP(pp_sge)
1222 {
1223     djSP; tryAMAGICbinSET(sge,0);
1224     {
1225       dPOPTOPssrl;
1226       int cmp = ((PL_op->op_private & OPpLOCALE)
1227                  ? sv_cmp_locale(left, right)
1228                  : sv_cmp(left, right));
1229       SETs(boolSV(cmp >= 0));
1230       RETURN;
1231     }
1232 }
1233
1234 PP(pp_seq)
1235 {
1236     djSP; tryAMAGICbinSET(seq,0);
1237     {
1238       dPOPTOPssrl;
1239       SETs(boolSV(sv_eq(left, right)));
1240       RETURN;
1241     }
1242 }
1243
1244 PP(pp_sne)
1245 {
1246     djSP; tryAMAGICbinSET(sne,0);
1247     {
1248       dPOPTOPssrl;
1249       SETs(boolSV(!sv_eq(left, right)));
1250       RETURN;
1251     }
1252 }
1253
1254 PP(pp_scmp)
1255 {
1256     djSP; dTARGET;  tryAMAGICbin(scmp,0);
1257     {
1258       dPOPTOPssrl;
1259       int cmp = ((PL_op->op_private & OPpLOCALE)
1260                  ? sv_cmp_locale(left, right)
1261                  : sv_cmp(left, right));
1262       SETi( cmp );
1263       RETURN;
1264     }
1265 }
1266
1267 PP(pp_bit_and)
1268 {
1269     djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1270     {
1271       dPOPTOPssrl;
1272       if (SvNIOKp(left) || SvNIOKp(right)) {
1273         if (PL_op->op_private & HINT_INTEGER) {
1274           IBW value = SvIV(left) & SvIV(right);
1275           SETi(BWi(value));
1276         }
1277         else {
1278           UBW value = SvUV(left) & SvUV(right);
1279           SETu(BWu(value));
1280         }
1281       }
1282       else {
1283         do_vop(PL_op->op_type, TARG, left, right);
1284         SETTARG;
1285       }
1286       RETURN;
1287     }
1288 }
1289
1290 PP(pp_bit_xor)
1291 {
1292     djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1293     {
1294       dPOPTOPssrl;
1295       if (SvNIOKp(left) || SvNIOKp(right)) {
1296         if (PL_op->op_private & HINT_INTEGER) {
1297           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1298           SETi(BWi(value));
1299         }
1300         else {
1301           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1302           SETu(BWu(value));
1303         }
1304       }
1305       else {
1306         do_vop(PL_op->op_type, TARG, left, right);
1307         SETTARG;
1308       }
1309       RETURN;
1310     }
1311 }
1312
1313 PP(pp_bit_or)
1314 {
1315     djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1316     {
1317       dPOPTOPssrl;
1318       if (SvNIOKp(left) || SvNIOKp(right)) {
1319         if (PL_op->op_private & HINT_INTEGER) {
1320           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1321           SETi(BWi(value));
1322         }
1323         else {
1324           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1325           SETu(BWu(value));
1326         }
1327       }
1328       else {
1329         do_vop(PL_op->op_type, TARG, left, right);
1330         SETTARG;
1331       }
1332       RETURN;
1333     }
1334 }
1335
1336 PP(pp_negate)
1337 {
1338     djSP; dTARGET; tryAMAGICun(neg);
1339     {
1340         dTOPss;
1341         if (SvGMAGICAL(sv))
1342             mg_get(sv);
1343         if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1344             SETi(-SvIVX(sv));
1345         else if (SvNIOKp(sv))
1346             SETn(-SvNV(sv));
1347         else if (SvPOKp(sv)) {
1348             STRLEN len;
1349             char *s = SvPV(sv, len);
1350             if (isIDFIRST(*s)) {
1351                 sv_setpvn(TARG, "-", 1);
1352                 sv_catsv(TARG, sv);
1353             }
1354             else if (*s == '+' || *s == '-') {
1355                 sv_setsv(TARG, sv);
1356                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1357             }
1358             else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1359                 sv_setpvn(TARG, "-", 1);
1360                 sv_catsv(TARG, sv);
1361             }
1362             else
1363                 sv_setnv(TARG, -SvNV(sv));
1364             SETTARG;
1365         }
1366         else
1367             SETn(-SvNV(sv));
1368     }
1369     RETURN;
1370 }
1371
1372 PP(pp_not)
1373 {
1374     djSP; tryAMAGICunSET(not);
1375     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1376     return NORMAL;
1377 }
1378
1379 PP(pp_complement)
1380 {
1381     djSP; dTARGET; tryAMAGICun(compl);
1382     {
1383       dTOPss;
1384       if (SvNIOKp(sv)) {
1385         if (PL_op->op_private & HINT_INTEGER) {
1386           IBW value = ~SvIV(sv);
1387           SETi(BWi(value));
1388         }
1389         else {
1390           UBW value = ~SvUV(sv);
1391           SETu(BWu(value));
1392         }
1393       }
1394       else {
1395         register char *tmps;
1396         register long *tmpl;
1397         register I32 anum;
1398         STRLEN len;
1399
1400         SvSetSV(TARG, sv);
1401         tmps = SvPV_force(TARG, len);
1402         anum = len;
1403 #ifdef LIBERAL
1404         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1405             *tmps = ~*tmps;
1406         tmpl = (long*)tmps;
1407         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1408             *tmpl = ~*tmpl;
1409         tmps = (char*)tmpl;
1410 #endif
1411         for ( ; anum > 0; anum--, tmps++)
1412             *tmps = ~*tmps;
1413
1414         SETs(TARG);
1415       }
1416       RETURN;
1417     }
1418 }
1419
1420 /* integer versions of some of the above */
1421
1422 PP(pp_i_multiply)
1423 {
1424     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1425     {
1426       dPOPTOPiirl;
1427       SETi( left * right );
1428       RETURN;
1429     }
1430 }
1431
1432 PP(pp_i_divide)
1433 {
1434     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1435     {
1436       dPOPiv;
1437       if (value == 0)
1438         DIE("Illegal division by zero");
1439       value = POPi / value;
1440       PUSHi( value );
1441       RETURN;
1442     }
1443 }
1444
1445 PP(pp_i_modulo)
1446 {
1447     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1448     {
1449       dPOPTOPiirl;
1450       if (!right)
1451         DIE("Illegal modulus zero");
1452       SETi( left % right );
1453       RETURN;
1454     }
1455 }
1456
1457 PP(pp_i_add)
1458 {
1459     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1460     {
1461       dPOPTOPiirl;
1462       SETi( left + right );
1463       RETURN;
1464     }
1465 }
1466
1467 PP(pp_i_subtract)
1468 {
1469     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1470     {
1471       dPOPTOPiirl;
1472       SETi( left - right );
1473       RETURN;
1474     }
1475 }
1476
1477 PP(pp_i_lt)
1478 {
1479     djSP; tryAMAGICbinSET(lt,0);
1480     {
1481       dPOPTOPiirl;
1482       SETs(boolSV(left < right));
1483       RETURN;
1484     }
1485 }
1486
1487 PP(pp_i_gt)
1488 {
1489     djSP; tryAMAGICbinSET(gt,0);
1490     {
1491       dPOPTOPiirl;
1492       SETs(boolSV(left > right));
1493       RETURN;
1494     }
1495 }
1496
1497 PP(pp_i_le)
1498 {
1499     djSP; tryAMAGICbinSET(le,0);
1500     {
1501       dPOPTOPiirl;
1502       SETs(boolSV(left <= right));
1503       RETURN;
1504     }
1505 }
1506
1507 PP(pp_i_ge)
1508 {
1509     djSP; tryAMAGICbinSET(ge,0);
1510     {
1511       dPOPTOPiirl;
1512       SETs(boolSV(left >= right));
1513       RETURN;
1514     }
1515 }
1516
1517 PP(pp_i_eq)
1518 {
1519     djSP; tryAMAGICbinSET(eq,0);
1520     {
1521       dPOPTOPiirl;
1522       SETs(boolSV(left == right));
1523       RETURN;
1524     }
1525 }
1526
1527 PP(pp_i_ne)
1528 {
1529     djSP; tryAMAGICbinSET(ne,0);
1530     {
1531       dPOPTOPiirl;
1532       SETs(boolSV(left != right));
1533       RETURN;
1534     }
1535 }
1536
1537 PP(pp_i_ncmp)
1538 {
1539     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1540     {
1541       dPOPTOPiirl;
1542       I32 value;
1543
1544       if (left > right)
1545         value = 1;
1546       else if (left < right)
1547         value = -1;
1548       else
1549         value = 0;
1550       SETi(value);
1551       RETURN;
1552     }
1553 }
1554
1555 PP(pp_i_negate)
1556 {
1557     djSP; dTARGET; tryAMAGICun(neg);
1558     SETi(-TOPi);
1559     RETURN;
1560 }
1561
1562 /* High falutin' math. */
1563
1564 PP(pp_atan2)
1565 {
1566     djSP; dTARGET; tryAMAGICbin(atan2,0);
1567     {
1568       dPOPTOPnnrl;
1569       SETn(atan2(left, right));
1570       RETURN;
1571     }
1572 }
1573
1574 PP(pp_sin)
1575 {
1576     djSP; dTARGET; tryAMAGICun(sin);
1577     {
1578       double value;
1579       value = POPn;
1580       value = sin(value);
1581       XPUSHn(value);
1582       RETURN;
1583     }
1584 }
1585
1586 PP(pp_cos)
1587 {
1588     djSP; dTARGET; tryAMAGICun(cos);
1589     {
1590       double value;
1591       value = POPn;
1592       value = cos(value);
1593       XPUSHn(value);
1594       RETURN;
1595     }
1596 }
1597
1598 /* Support Configure command-line overrides for rand() functions.
1599    After 5.005, perhaps we should replace this by Configure support
1600    for drand48(), random(), or rand().  For 5.005, though, maintain
1601    compatibility by calling rand() but allow the user to override it.
1602    See INSTALL for details.  --Andy Dougherty  15 July 1998
1603 */
1604 /* Now it's after 5.005, and Configure supports drand48() and random(),
1605    in addition to rand().  So the overrides should not be needed any more.
1606    --Jarkko Hietaniemi  27 September 1998
1607  */
1608
1609 #ifndef HAS_DRAND48_PROTO
1610 extern double drand48 _((void));
1611 #endif
1612
1613 PP(pp_rand)
1614 {
1615     djSP; dTARGET;
1616     double value;
1617     if (MAXARG < 1)
1618         value = 1.0;
1619     else
1620         value = POPn;
1621     if (value == 0.0)
1622         value = 1.0;
1623     if (!PL_srand_called) {
1624         (void)seedDrand01((Rand_seed_t)seed());
1625         PL_srand_called = TRUE;
1626     }
1627     value *= Drand01();
1628     XPUSHn(value);
1629     RETURN;
1630 }
1631
1632 PP(pp_srand)
1633 {
1634     djSP;
1635     UV anum;
1636     if (MAXARG < 1)
1637         anum = seed();
1638     else
1639         anum = POPu;
1640     (void)seedDrand01((Rand_seed_t)anum);
1641     PL_srand_called = TRUE;
1642     EXTEND(SP, 1);
1643     RETPUSHYES;
1644 }
1645
1646 STATIC U32
1647 seed(void)
1648 {
1649     /*
1650      * This is really just a quick hack which grabs various garbage
1651      * values.  It really should be a real hash algorithm which
1652      * spreads the effect of every input bit onto every output bit,
1653      * if someone who knows about such things would bother to write it.
1654      * Might be a good idea to add that function to CORE as well.
1655      * No numbers below come from careful analysis or anything here,
1656      * except they are primes and SEED_C1 > 1E6 to get a full-width
1657      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1658      * probably be bigger too.
1659      */
1660 #if RANDBITS > 16
1661 #  define SEED_C1       1000003
1662 #define   SEED_C4       73819
1663 #else
1664 #  define SEED_C1       25747
1665 #define   SEED_C4       20639
1666 #endif
1667 #define   SEED_C2       3
1668 #define   SEED_C3       269
1669 #define   SEED_C5       26107
1670
1671     dTHR;
1672 #ifndef PERL_NO_DEV_RANDOM
1673     int fd;
1674 #endif
1675     U32 u;
1676 #ifdef VMS
1677 #  include <starlet.h>
1678     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1679      * in 100-ns units, typically incremented ever 10 ms.        */
1680     unsigned int when[2];
1681 #else
1682 #  ifdef HAS_GETTIMEOFDAY
1683     struct timeval when;
1684 #  else
1685     Time_t when;
1686 #  endif
1687 #endif
1688
1689 /* This test is an escape hatch, this symbol isn't set by Configure. */
1690 #ifndef PERL_NO_DEV_RANDOM
1691 #ifndef PERL_RANDOM_DEVICE
1692    /* /dev/random isn't used by default because reads from it will block
1693     * if there isn't enough entropy available.  You can compile with
1694     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1695     * is enough real entropy to fill the seed. */
1696 #  define PERL_RANDOM_DEVICE "/dev/urandom"
1697 #endif
1698     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1699     if (fd != -1) {
1700         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1701             u = 0;
1702         PerlLIO_close(fd);
1703         if (u)
1704             return u;
1705     }
1706 #endif
1707
1708 #ifdef VMS
1709     _ckvmssts(sys$gettim(when));
1710     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1711 #else
1712 #  ifdef HAS_GETTIMEOFDAY
1713     gettimeofday(&when,(struct timezone *) 0);
1714     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1715 #  else
1716     (void)time(&when);
1717     u = (U32)SEED_C1 * when;
1718 #  endif
1719 #endif
1720     u += SEED_C3 * (U32)getpid();
1721     u += SEED_C4 * (U32)(UV)PL_stack_sp;
1722 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1723     u += SEED_C5 * (U32)(UV)&when;
1724 #endif
1725     return u;
1726 }
1727
1728 PP(pp_exp)
1729 {
1730     djSP; dTARGET; tryAMAGICun(exp);
1731     {
1732       double value;
1733       value = POPn;
1734       value = exp(value);
1735       XPUSHn(value);
1736       RETURN;
1737     }
1738 }
1739
1740 PP(pp_log)
1741 {
1742     djSP; dTARGET; tryAMAGICun(log);
1743     {
1744       double value;
1745       value = POPn;
1746       if (value <= 0.0) {
1747         SET_NUMERIC_STANDARD();
1748         DIE("Can't take log of %g", value);
1749       }
1750       value = log(value);
1751       XPUSHn(value);
1752       RETURN;
1753     }
1754 }
1755
1756 PP(pp_sqrt)
1757 {
1758     djSP; dTARGET; tryAMAGICun(sqrt);
1759     {
1760       double value;
1761       value = POPn;
1762       if (value < 0.0) {
1763         SET_NUMERIC_STANDARD();
1764         DIE("Can't take sqrt of %g", value);
1765       }
1766       value = sqrt(value);
1767       XPUSHn(value);
1768       RETURN;
1769     }
1770 }
1771
1772 PP(pp_int)
1773 {
1774     djSP; dTARGET;
1775     {
1776       double value = TOPn;
1777       IV iv;
1778
1779       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1780         iv = SvIVX(TOPs);
1781         SETi(iv);
1782       }
1783       else {
1784         if (value >= 0.0)
1785           (void)modf(value, &value);
1786         else {
1787           (void)modf(-value, &value);
1788           value = -value;
1789         }
1790         iv = I_V(value);
1791         if (iv == value)
1792           SETi(iv);
1793         else
1794           SETn(value);
1795       }
1796     }
1797     RETURN;
1798 }
1799
1800 PP(pp_abs)
1801 {
1802     djSP; dTARGET; tryAMAGICun(abs);
1803     {
1804       double value = TOPn;
1805       IV iv;
1806
1807       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1808           (iv = SvIVX(TOPs)) != IV_MIN) {
1809         if (iv < 0)
1810           iv = -iv;
1811         SETi(iv);
1812       }
1813       else {
1814         if (value < 0.0)
1815             value = -value;
1816         SETn(value);
1817       }
1818     }
1819     RETURN;
1820 }
1821
1822 PP(pp_hex)
1823 {
1824     djSP; dTARGET;
1825     char *tmps;
1826     I32 argtype;
1827     STRLEN n_a;
1828
1829     tmps = POPpx;
1830     XPUSHu(scan_hex(tmps, 99, &argtype));
1831     RETURN;
1832 }
1833
1834 PP(pp_oct)
1835 {
1836     djSP; dTARGET;
1837     UV value;
1838     I32 argtype;
1839     char *tmps;
1840     STRLEN n_a;
1841
1842     tmps = POPpx;
1843     while (*tmps && isSPACE(*tmps))
1844         tmps++;
1845     if (*tmps == '0')
1846         tmps++;
1847     if (*tmps == 'x')
1848         value = scan_hex(++tmps, 99, &argtype);
1849     else if (*tmps == 'b')
1850         value = scan_bin(++tmps, 99, &argtype);
1851     else
1852         value = scan_oct(tmps, 99, &argtype);
1853     XPUSHu(value);
1854     RETURN;
1855 }
1856
1857 /* String stuff. */
1858
1859 PP(pp_length)
1860 {
1861     djSP; dTARGET;
1862
1863     if (IN_UTF8) {
1864         SETi( sv_len_utf8(TOPs) );
1865         RETURN;
1866     }
1867
1868     SETi( sv_len(TOPs) );
1869     RETURN;
1870 }
1871
1872 PP(pp_substr)
1873 {
1874     djSP; dTARGET;
1875     SV *sv;
1876     I32 len;
1877     STRLEN curlen;
1878     STRLEN utfcurlen;
1879     I32 pos;
1880     I32 rem;
1881     I32 fail;
1882     I32 lvalue = PL_op->op_flags & OPf_MOD;
1883     char *tmps;
1884     I32 arybase = PL_curcop->cop_arybase;
1885     char *repl = 0;
1886     STRLEN repl_len;
1887
1888     SvTAINTED_off(TARG);                        /* decontaminate */
1889     if (MAXARG > 2) {
1890         if (MAXARG > 3) {
1891             sv = POPs;
1892             repl = SvPV(sv, repl_len);
1893         }
1894         len = POPi;
1895     }
1896     pos = POPi;
1897     sv = POPs;
1898     PUTBACK;
1899     tmps = SvPV(sv, curlen);
1900     if (IN_UTF8) {
1901         utfcurlen = sv_len_utf8(sv);
1902         if (utfcurlen == curlen)
1903             utfcurlen = 0;
1904         else
1905             curlen = utfcurlen;
1906     }
1907     else
1908         utfcurlen = 0;
1909
1910     if (pos >= arybase) {
1911         pos -= arybase;
1912         rem = curlen-pos;
1913         fail = rem;
1914         if (MAXARG > 2) {
1915             if (len < 0) {
1916                 rem += len;
1917                 if (rem < 0)
1918                     rem = 0;
1919             }
1920             else if (rem > len)
1921                      rem = len;
1922         }
1923     }
1924     else {
1925         pos += curlen;
1926         if (MAXARG < 3)
1927             rem = curlen;
1928         else if (len >= 0) {
1929             rem = pos+len;
1930             if (rem > (I32)curlen)
1931                 rem = curlen;
1932         }
1933         else {
1934             rem = curlen+len;
1935             if (rem < pos)
1936                 rem = pos;
1937         }
1938         if (pos < 0)
1939             pos = 0;
1940         fail = rem;
1941         rem -= pos;
1942     }
1943     if (fail < 0) {
1944         if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1945             warner(WARN_SUBSTR, "substr outside of string");
1946         RETPUSHUNDEF;
1947     }
1948     else {
1949         if (utfcurlen)
1950             sv_pos_u2b(sv, &pos, &rem);
1951         tmps += pos;
1952         sv_setpvn(TARG, tmps, rem);
1953         if (lvalue) {                   /* it's an lvalue! */
1954             if (!SvGMAGICAL(sv)) {
1955                 if (SvROK(sv)) {
1956                     STRLEN n_a;
1957                     SvPV_force(sv,n_a);
1958                     if (ckWARN(WARN_SUBSTR))
1959                         warner(WARN_SUBSTR,
1960                                 "Attempt to use reference as lvalue in substr");
1961                 }
1962                 if (SvOK(sv))           /* is it defined ? */
1963                     (void)SvPOK_only(sv);
1964                 else
1965                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1966             }
1967
1968             if (SvTYPE(TARG) < SVt_PVLV) {
1969                 sv_upgrade(TARG, SVt_PVLV);
1970                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1971             }
1972
1973             LvTYPE(TARG) = 'x';
1974             if (LvTARG(TARG) != sv) {
1975                 if (LvTARG(TARG))
1976                     SvREFCNT_dec(LvTARG(TARG));
1977                 LvTARG(TARG) = SvREFCNT_inc(sv);
1978             }
1979             LvTARGOFF(TARG) = pos;
1980             LvTARGLEN(TARG) = rem;
1981         }
1982         else if (repl)
1983             sv_insert(sv, pos, rem, repl, repl_len);
1984     }
1985     SPAGAIN;
1986     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1987     RETURN;
1988 }
1989
1990 PP(pp_vec)
1991 {
1992     djSP; dTARGET;
1993     register I32 size = POPi;
1994     register I32 offset = POPi;
1995     register SV *src = POPs;
1996     I32 lvalue = PL_op->op_flags & OPf_MOD;
1997     STRLEN srclen;
1998     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1999     unsigned long retnum;
2000     I32 len;
2001
2002     SvTAINTED_off(TARG);                        /* decontaminate */
2003     offset *= size;             /* turn into bit offset */
2004     len = (offset + size + 7) / 8;
2005     if (offset < 0 || size < 1)
2006         retnum = 0;
2007     else {
2008         if (lvalue) {                      /* it's an lvalue! */
2009             if (SvTYPE(TARG) < SVt_PVLV) {
2010                 sv_upgrade(TARG, SVt_PVLV);
2011                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2012             }
2013
2014             LvTYPE(TARG) = 'v';
2015             if (LvTARG(TARG) != src) {
2016                 if (LvTARG(TARG))
2017                     SvREFCNT_dec(LvTARG(TARG));
2018                 LvTARG(TARG) = SvREFCNT_inc(src);
2019             }
2020             LvTARGOFF(TARG) = offset;
2021             LvTARGLEN(TARG) = size;
2022         }
2023         if (len > srclen) {
2024             if (size <= 8)
2025                 retnum = 0;
2026             else {
2027                 offset >>= 3;
2028                 if (size == 16) {
2029                     if (offset >= srclen)
2030                         retnum = 0;
2031                     else
2032                         retnum = (unsigned long) s[offset] << 8;
2033                 }
2034                 else if (size == 32) {
2035                     if (offset >= srclen)
2036                         retnum = 0;
2037                     else if (offset + 1 >= srclen)
2038                         retnum = (unsigned long) s[offset] << 24;
2039                     else if (offset + 2 >= srclen)
2040                         retnum = ((unsigned long) s[offset] << 24) +
2041                             ((unsigned long) s[offset + 1] << 16);
2042                     else
2043                         retnum = ((unsigned long) s[offset] << 24) +
2044                             ((unsigned long) s[offset + 1] << 16) +
2045                             (s[offset + 2] << 8);
2046                 }
2047             }
2048         }
2049         else if (size < 8)
2050             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2051         else {
2052             offset >>= 3;
2053             if (size == 8)
2054                 retnum = s[offset];
2055             else if (size == 16)
2056                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2057             else if (size == 32)
2058                 retnum = ((unsigned long) s[offset] << 24) +
2059                         ((unsigned long) s[offset + 1] << 16) +
2060                         (s[offset + 2] << 8) + s[offset+3];
2061         }
2062     }
2063
2064     sv_setuv(TARG, (UV)retnum);
2065     PUSHs(TARG);
2066     RETURN;
2067 }
2068
2069 PP(pp_index)
2070 {
2071     djSP; dTARGET;
2072     SV *big;
2073     SV *little;
2074     I32 offset;
2075     I32 retval;
2076     char *tmps;
2077     char *tmps2;
2078     STRLEN biglen;
2079     I32 arybase = PL_curcop->cop_arybase;
2080
2081     if (MAXARG < 3)
2082         offset = 0;
2083     else
2084         offset = POPi - arybase;
2085     little = POPs;
2086     big = POPs;
2087     tmps = SvPV(big, biglen);
2088     if (IN_UTF8 && offset > 0)
2089         sv_pos_u2b(big, &offset, 0);
2090     if (offset < 0)
2091         offset = 0;
2092     else if (offset > biglen)
2093         offset = biglen;
2094     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2095       (unsigned char*)tmps + biglen, little, 0)))
2096         retval = -1;
2097     else
2098         retval = tmps2 - tmps;
2099     if (IN_UTF8 && retval > 0)
2100         sv_pos_b2u(big, &retval);
2101     PUSHi(retval + arybase);
2102     RETURN;
2103 }
2104
2105 PP(pp_rindex)
2106 {
2107     djSP; dTARGET;
2108     SV *big;
2109     SV *little;
2110     STRLEN blen;
2111     STRLEN llen;
2112     I32 offset;
2113     I32 retval;
2114     char *tmps;
2115     char *tmps2;
2116     I32 arybase = PL_curcop->cop_arybase;
2117
2118     if (MAXARG >= 3)
2119         offset = POPi;
2120     little = POPs;
2121     big = POPs;
2122     tmps2 = SvPV(little, llen);
2123     tmps = SvPV(big, blen);
2124     if (MAXARG < 3)
2125         offset = blen;
2126     else {
2127         if (IN_UTF8 && offset > 0)
2128             sv_pos_u2b(big, &offset, 0);
2129         offset = offset - arybase + llen;
2130     }
2131     if (offset < 0)
2132         offset = 0;
2133     else if (offset > blen)
2134         offset = blen;
2135     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2136                           tmps2, tmps2 + llen)))
2137         retval = -1;
2138     else
2139         retval = tmps2 - tmps;
2140     if (IN_UTF8 && retval > 0)
2141         sv_pos_b2u(big, &retval);
2142     PUSHi(retval + arybase);
2143     RETURN;
2144 }
2145
2146 PP(pp_sprintf)
2147 {
2148     djSP; dMARK; dORIGMARK; dTARGET;
2149 #ifdef USE_LOCALE_NUMERIC
2150     if (PL_op->op_private & OPpLOCALE)
2151         SET_NUMERIC_LOCAL();
2152     else
2153         SET_NUMERIC_STANDARD();
2154 #endif
2155     do_sprintf(TARG, SP-MARK, MARK+1);
2156     TAINT_IF(SvTAINTED(TARG));
2157     SP = ORIGMARK;
2158     PUSHTARG;
2159     RETURN;
2160 }
2161
2162 PP(pp_ord)
2163 {
2164     djSP; dTARGET;
2165     UV value;
2166     STRLEN n_a;
2167     U8 *tmps = (U8*)POPpx;
2168     I32 retlen;
2169
2170     if (IN_UTF8 && (*tmps & 0x80))
2171         value = utf8_to_uv(tmps, &retlen);
2172     else
2173         value = (UV)(*tmps & 255);
2174     XPUSHu(value);
2175     RETURN;
2176 }
2177
2178 PP(pp_chr)
2179 {
2180     djSP; dTARGET;
2181     char *tmps;
2182     U32 value = POPu;
2183
2184     (void)SvUPGRADE(TARG,SVt_PV);
2185
2186     if (IN_UTF8 && value >= 128) {
2187         SvGROW(TARG,8);
2188         tmps = SvPVX(TARG);
2189         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2190         SvCUR_set(TARG, tmps - SvPVX(TARG));
2191         *tmps = '\0';
2192         (void)SvPOK_only(TARG);
2193         XPUSHs(TARG);
2194         RETURN;
2195     }
2196
2197     SvGROW(TARG,2);
2198     SvCUR_set(TARG, 1);
2199     tmps = SvPVX(TARG);
2200     *tmps++ = value;
2201     *tmps = '\0';
2202     (void)SvPOK_only(TARG);
2203     XPUSHs(TARG);
2204     RETURN;
2205 }
2206
2207 PP(pp_crypt)
2208 {
2209     djSP; dTARGET; dPOPTOPssrl;
2210     STRLEN n_a;
2211 #ifdef HAS_CRYPT
2212     char *tmps = SvPV(left, n_a);
2213 #ifdef FCRYPT
2214     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2215 #else
2216     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2217 #endif
2218 #else
2219     DIE(
2220       "The crypt() function is unimplemented due to excessive paranoia.");
2221 #endif
2222     SETs(TARG);
2223     RETURN;
2224 }
2225
2226 PP(pp_ucfirst)
2227 {
2228     djSP;
2229     SV *sv = TOPs;
2230     register U8 *s;
2231     STRLEN slen;
2232
2233     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2234         I32 ulen;
2235         U8 tmpbuf[10];
2236         U8 *tend;
2237         UV uv = utf8_to_uv(s, &ulen);
2238
2239         if (PL_op->op_private & OPpLOCALE) {
2240             TAINT;
2241             SvTAINTED_on(sv);
2242             uv = toTITLE_LC_uni(uv);
2243         }
2244         else
2245             uv = toTITLE_utf8(s);
2246
2247         tend = uv_to_utf8(tmpbuf, uv);
2248
2249         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2250             dTARGET;
2251             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2252             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2253             SETs(TARG);
2254         }
2255         else {
2256             s = (U8*)SvPV_force(sv, slen);
2257             Copy(tmpbuf, s, ulen, U8);
2258         }
2259         RETURN;
2260     }
2261
2262     if (!SvPADTMP(sv)) {
2263         dTARGET;
2264         sv_setsv(TARG, sv);
2265         sv = TARG;
2266         SETs(sv);
2267     }
2268     s = (U8*)SvPV_force(sv, slen);
2269     if (*s) {
2270         if (PL_op->op_private & OPpLOCALE) {
2271             TAINT;
2272             SvTAINTED_on(sv);
2273             *s = toUPPER_LC(*s);
2274         }
2275         else
2276             *s = toUPPER(*s);
2277     }
2278
2279     RETURN;
2280 }
2281
2282 PP(pp_lcfirst)
2283 {
2284     djSP;
2285     SV *sv = TOPs;
2286     register U8 *s;
2287     STRLEN slen;
2288
2289     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2290         I32 ulen;
2291         U8 tmpbuf[10];
2292         U8 *tend;
2293         UV uv = utf8_to_uv(s, &ulen);
2294
2295         if (PL_op->op_private & OPpLOCALE) {
2296             TAINT;
2297             SvTAINTED_on(sv);
2298             uv = toLOWER_LC_uni(uv);
2299         }
2300         else
2301             uv = toLOWER_utf8(s);
2302
2303         tend = uv_to_utf8(tmpbuf, uv);
2304
2305         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2306             dTARGET;
2307             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2308             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2309             SETs(TARG);
2310         }
2311         else {
2312             s = (U8*)SvPV_force(sv, slen);
2313             Copy(tmpbuf, s, ulen, U8);
2314         }
2315         RETURN;
2316     }
2317
2318     if (!SvPADTMP(sv)) {
2319         dTARGET;
2320         sv_setsv(TARG, sv);
2321         sv = TARG;
2322         SETs(sv);
2323     }
2324     s = (U8*)SvPV_force(sv, slen);
2325     if (*s) {
2326         if (PL_op->op_private & OPpLOCALE) {
2327             TAINT;
2328             SvTAINTED_on(sv);
2329             *s = toLOWER_LC(*s);
2330         }
2331         else
2332             *s = toLOWER(*s);
2333     }
2334
2335     SETs(sv);
2336     RETURN;
2337 }
2338
2339 PP(pp_uc)
2340 {
2341     djSP;
2342     SV *sv = TOPs;
2343     register U8 *s;
2344     STRLEN len;
2345
2346     if (IN_UTF8) {
2347         dTARGET;
2348         I32 ulen;
2349         register U8 *d;
2350         U8 *send;
2351
2352         s = (U8*)SvPV(sv,len);
2353         if (!len) {
2354             sv_setpvn(TARG, "", 0);
2355             SETs(TARG);
2356             RETURN;
2357         }
2358
2359         (void)SvUPGRADE(TARG, SVt_PV);
2360         SvGROW(TARG, (len * 2) + 1);
2361         (void)SvPOK_only(TARG);
2362         d = (U8*)SvPVX(TARG);
2363         send = s + len;
2364         if (PL_op->op_private & OPpLOCALE) {
2365             TAINT;
2366             SvTAINTED_on(TARG);
2367             while (s < send) {
2368                 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2369                 s += ulen;
2370             }
2371         }
2372         else {
2373             while (s < send) {
2374                 d = uv_to_utf8(d, toUPPER_utf8( s ));
2375                 s += UTF8SKIP(s);
2376             }
2377         }
2378         *d = '\0';
2379         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2380         SETs(TARG);
2381         RETURN;
2382     }
2383
2384     if (!SvPADTMP(sv)) {
2385         dTARGET;
2386         sv_setsv(TARG, sv);
2387         sv = TARG;
2388         SETs(sv);
2389     }
2390
2391     s = (U8*)SvPV_force(sv, len);
2392     if (len) {
2393         register U8 *send = s + len;
2394
2395         if (PL_op->op_private & OPpLOCALE) {
2396             TAINT;
2397             SvTAINTED_on(sv);
2398             for (; s < send; s++)
2399                 *s = toUPPER_LC(*s);
2400         }
2401         else {
2402             for (; s < send; s++)
2403                 *s = toUPPER(*s);
2404         }
2405     }
2406     RETURN;
2407 }
2408
2409 PP(pp_lc)
2410 {
2411     djSP;
2412     SV *sv = TOPs;
2413     register U8 *s;
2414     STRLEN len;
2415
2416     if (IN_UTF8) {
2417         dTARGET;
2418         I32 ulen;
2419         register U8 *d;
2420         U8 *send;
2421
2422         s = (U8*)SvPV(sv,len);
2423         if (!len) {
2424             sv_setpvn(TARG, "", 0);
2425             SETs(TARG);
2426             RETURN;
2427         }
2428
2429         (void)SvUPGRADE(TARG, SVt_PV);
2430         SvGROW(TARG, (len * 2) + 1);
2431         (void)SvPOK_only(TARG);
2432         d = (U8*)SvPVX(TARG);
2433         send = s + len;
2434         if (PL_op->op_private & OPpLOCALE) {
2435             TAINT;
2436             SvTAINTED_on(TARG);
2437             while (s < send) {
2438                 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2439                 s += ulen;
2440             }
2441         }
2442         else {
2443             while (s < send) {
2444                 d = uv_to_utf8(d, toLOWER_utf8(s));
2445                 s += UTF8SKIP(s);
2446             }
2447         }
2448         *d = '\0';
2449         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2450         SETs(TARG);
2451         RETURN;
2452     }
2453
2454     if (!SvPADTMP(sv)) {
2455         dTARGET;
2456         sv_setsv(TARG, sv);
2457         sv = TARG;
2458         SETs(sv);
2459     }
2460
2461     s = (U8*)SvPV_force(sv, len);
2462     if (len) {
2463         register U8 *send = s + len;
2464
2465         if (PL_op->op_private & OPpLOCALE) {
2466             TAINT;
2467             SvTAINTED_on(sv);
2468             for (; s < send; s++)
2469                 *s = toLOWER_LC(*s);
2470         }
2471         else {
2472             for (; s < send; s++)
2473                 *s = toLOWER(*s);
2474         }
2475     }
2476     RETURN;
2477 }
2478
2479 PP(pp_quotemeta)
2480 {
2481     djSP; dTARGET;
2482     SV *sv = TOPs;
2483     STRLEN len;
2484     register char *s = SvPV(sv,len);
2485     register char *d;
2486
2487     if (len) {
2488         (void)SvUPGRADE(TARG, SVt_PV);
2489         SvGROW(TARG, (len * 2) + 1);
2490         d = SvPVX(TARG);
2491         if (IN_UTF8) {
2492             while (len) {
2493                 if (*s & 0x80) {
2494                     STRLEN ulen = UTF8SKIP(s);
2495                     if (ulen > len)
2496                         ulen = len;
2497                     len -= ulen;
2498                     while (ulen--)
2499                         *d++ = *s++;
2500                 }
2501                 else {
2502                     if (!isALNUM(*s))
2503                         *d++ = '\\';
2504                     *d++ = *s++;
2505                     len--;
2506                 }
2507             }
2508         }
2509         else {
2510             while (len--) {
2511                 if (!isALNUM(*s))
2512                     *d++ = '\\';
2513                 *d++ = *s++;
2514             }
2515         }
2516         *d = '\0';
2517         SvCUR_set(TARG, d - SvPVX(TARG));
2518         (void)SvPOK_only(TARG);
2519     }
2520     else
2521         sv_setpvn(TARG, s, len);
2522     SETs(TARG);
2523     RETURN;
2524 }
2525
2526 /* Arrays. */
2527
2528 PP(pp_aslice)
2529 {
2530     djSP; dMARK; dORIGMARK;
2531     register SV** svp;
2532     register AV* av = (AV*)POPs;
2533     register I32 lval = PL_op->op_flags & OPf_MOD;
2534     I32 arybase = PL_curcop->cop_arybase;
2535     I32 elem;
2536
2537     if (SvTYPE(av) == SVt_PVAV) {
2538         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2539             I32 max = -1;
2540             for (svp = MARK + 1; svp <= SP; svp++) {
2541                 elem = SvIVx(*svp);
2542                 if (elem > max)
2543                     max = elem;
2544             }
2545             if (max > AvMAX(av))
2546                 av_extend(av, max);
2547         }
2548         while (++MARK <= SP) {
2549             elem = SvIVx(*MARK);
2550
2551             if (elem > 0)
2552                 elem -= arybase;
2553             svp = av_fetch(av, elem, lval);
2554             if (lval) {
2555                 if (!svp || *svp == &PL_sv_undef)
2556                     DIE(PL_no_aelem, elem);
2557                 if (PL_op->op_private & OPpLVAL_INTRO)
2558                     save_aelem(av, elem, svp);
2559             }
2560             *MARK = svp ? *svp : &PL_sv_undef;
2561         }
2562     }
2563     if (GIMME != G_ARRAY) {
2564         MARK = ORIGMARK;
2565         *++MARK = *SP;
2566         SP = MARK;
2567     }
2568     RETURN;
2569 }
2570
2571 /* Associative arrays. */
2572
2573 PP(pp_each)
2574 {
2575     djSP; dTARGET;
2576     HV *hash = (HV*)POPs;
2577     HE *entry;
2578     I32 gimme = GIMME_V;
2579     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2580
2581     PUTBACK;
2582     /* might clobber stack_sp */
2583     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2584     SPAGAIN;
2585
2586     EXTEND(SP, 2);
2587     if (entry) {
2588         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2589         if (gimme == G_ARRAY) {
2590             PUTBACK;
2591             /* might clobber stack_sp */
2592             sv_setsv(TARG, realhv ?
2593                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2594             SPAGAIN;
2595             PUSHs(TARG);
2596         }
2597     }
2598     else if (gimme == G_SCALAR)
2599         RETPUSHUNDEF;
2600
2601     RETURN;
2602 }
2603
2604 PP(pp_values)
2605 {
2606     return do_kv(ARGS);
2607 }
2608
2609 PP(pp_keys)
2610 {
2611     return do_kv(ARGS);
2612 }
2613
2614 PP(pp_delete)
2615 {
2616     djSP;
2617     I32 gimme = GIMME_V;
2618     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2619     SV *sv;
2620     HV *hv;
2621
2622     if (PL_op->op_private & OPpSLICE) {
2623         dMARK; dORIGMARK;
2624         U32 hvtype;
2625         hv = (HV*)POPs;
2626         hvtype = SvTYPE(hv);
2627         while (++MARK <= SP) {
2628             if (hvtype == SVt_PVHV)
2629                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2630             else
2631                 DIE("Not a HASH reference");
2632             *MARK = sv ? sv : &PL_sv_undef;
2633         }
2634         if (discard)
2635             SP = ORIGMARK;
2636         else if (gimme == G_SCALAR) {
2637             MARK = ORIGMARK;
2638             *++MARK = *SP;
2639             SP = MARK;
2640         }
2641     }
2642     else {
2643         SV *keysv = POPs;
2644         hv = (HV*)POPs;
2645         if (SvTYPE(hv) == SVt_PVHV)
2646             sv = hv_delete_ent(hv, keysv, discard, 0);
2647         else
2648             DIE("Not a HASH reference");
2649         if (!sv)
2650             sv = &PL_sv_undef;
2651         if (!discard)
2652             PUSHs(sv);
2653     }
2654     RETURN;
2655 }
2656
2657 PP(pp_exists)
2658 {
2659     djSP;
2660     SV *tmpsv = POPs;
2661     HV *hv = (HV*)POPs;
2662     if (SvTYPE(hv) == SVt_PVHV) {
2663         if (hv_exists_ent(hv, tmpsv, 0))
2664             RETPUSHYES;
2665     }
2666     else if (SvTYPE(hv) == SVt_PVAV) {
2667         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2668             RETPUSHYES;
2669     }
2670     else {
2671         DIE("Not a HASH reference");
2672     }
2673     RETPUSHNO;
2674 }
2675
2676 PP(pp_hslice)
2677 {
2678     djSP; dMARK; dORIGMARK;
2679     register HV *hv = (HV*)POPs;
2680     register I32 lval = PL_op->op_flags & OPf_MOD;
2681     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2682
2683     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2684         DIE("Can't localize pseudo-hash element");
2685
2686     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2687         while (++MARK <= SP) {
2688             SV *keysv = *MARK;
2689             SV **svp;
2690             if (realhv) {
2691                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2692                 svp = he ? &HeVAL(he) : 0;
2693             }
2694             else {
2695                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2696             }
2697             if (lval) {
2698                 if (!svp || *svp == &PL_sv_undef) {
2699                     STRLEN n_a;
2700                     DIE(PL_no_helem, SvPV(keysv, n_a));
2701                 }
2702                 if (PL_op->op_private & OPpLVAL_INTRO)
2703                     save_helem(hv, keysv, svp);
2704             }
2705             *MARK = svp ? *svp : &PL_sv_undef;
2706         }
2707     }
2708     if (GIMME != G_ARRAY) {
2709         MARK = ORIGMARK;
2710         *++MARK = *SP;
2711         SP = MARK;
2712     }
2713     RETURN;
2714 }
2715
2716 /* List operators. */
2717
2718 PP(pp_list)
2719 {
2720     djSP; dMARK;
2721     if (GIMME != G_ARRAY) {
2722         if (++MARK <= SP)
2723             *MARK = *SP;                /* unwanted list, return last item */
2724         else
2725             *MARK = &PL_sv_undef;
2726         SP = MARK;
2727     }
2728     RETURN;
2729 }
2730
2731 PP(pp_lslice)
2732 {
2733     djSP;
2734     SV **lastrelem = PL_stack_sp;
2735     SV **lastlelem = PL_stack_base + POPMARK;
2736     SV **firstlelem = PL_stack_base + POPMARK + 1;
2737     register SV **firstrelem = lastlelem + 1;
2738     I32 arybase = PL_curcop->cop_arybase;
2739     I32 lval = PL_op->op_flags & OPf_MOD;
2740     I32 is_something_there = lval;
2741
2742     register I32 max = lastrelem - lastlelem;
2743     register SV **lelem;
2744     register I32 ix;
2745
2746     if (GIMME != G_ARRAY) {
2747         ix = SvIVx(*lastlelem);
2748         if (ix < 0)
2749             ix += max;
2750         else
2751             ix -= arybase;
2752         if (ix < 0 || ix >= max)
2753             *firstlelem = &PL_sv_undef;
2754         else
2755             *firstlelem = firstrelem[ix];
2756         SP = firstlelem;
2757         RETURN;
2758     }
2759
2760     if (max == 0) {
2761         SP = firstlelem - 1;
2762         RETURN;
2763     }
2764
2765     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2766         ix = SvIVx(*lelem);
2767         if (ix < 0) {
2768             ix += max;
2769             if (ix < 0)
2770                 *lelem = &PL_sv_undef;
2771             else if (!(*lelem = firstrelem[ix]))
2772                 *lelem = &PL_sv_undef;
2773         }
2774         else {
2775             ix -= arybase;
2776             if (ix >= max || !(*lelem = firstrelem[ix]))
2777                 *lelem = &PL_sv_undef;
2778         }
2779         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2780             is_something_there = TRUE;
2781     }
2782     if (is_something_there)
2783         SP = lastlelem;
2784     else
2785         SP = firstlelem - 1;
2786     RETURN;
2787 }
2788
2789 PP(pp_anonlist)
2790 {
2791     djSP; dMARK; dORIGMARK;
2792     I32 items = SP - MARK;
2793     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2794     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2795     XPUSHs(av);
2796     RETURN;
2797 }
2798
2799 PP(pp_anonhash)
2800 {
2801     djSP; dMARK; dORIGMARK;
2802     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2803
2804     while (MARK < SP) {
2805         SV* key = *++MARK;
2806         SV *val = NEWSV(46, 0);
2807         if (MARK < SP)
2808             sv_setsv(val, *++MARK);
2809         else if (ckWARN(WARN_UNSAFE))
2810             warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2811         (void)hv_store_ent(hv,key,val,0);
2812     }
2813     SP = ORIGMARK;
2814     XPUSHs((SV*)hv);
2815     RETURN;
2816 }
2817
2818 PP(pp_splice)
2819 {
2820     djSP; dMARK; dORIGMARK;
2821     register AV *ary = (AV*)*++MARK;
2822     register SV **src;
2823     register SV **dst;
2824     register I32 i;
2825     register I32 offset;
2826     register I32 length;
2827     I32 newlen;
2828     I32 after;
2829     I32 diff;
2830     SV **tmparyval = 0;
2831     MAGIC *mg;
2832
2833     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2834         *MARK-- = SvTIED_obj((SV*)ary, mg);
2835         PUSHMARK(MARK);
2836         PUTBACK;
2837         ENTER;
2838         perl_call_method("SPLICE",GIMME_V);
2839         LEAVE;
2840         SPAGAIN;
2841         RETURN;
2842     }
2843
2844     SP++;
2845
2846     if (++MARK < SP) {
2847         offset = i = SvIVx(*MARK);
2848         if (offset < 0)
2849             offset += AvFILLp(ary) + 1;
2850         else
2851             offset -= PL_curcop->cop_arybase;
2852         if (offset < 0)
2853             DIE(PL_no_aelem, i);
2854         if (++MARK < SP) {
2855             length = SvIVx(*MARK++);
2856             if (length < 0) {
2857                 length += AvFILLp(ary) - offset + 1;
2858                 if (length < 0)
2859                     length = 0;
2860             }
2861         }
2862         else
2863             length = AvMAX(ary) + 1;            /* close enough to infinity */
2864     }
2865     else {
2866         offset = 0;
2867         length = AvMAX(ary) + 1;
2868     }
2869     if (offset > AvFILLp(ary) + 1)
2870         offset = AvFILLp(ary) + 1;
2871     after = AvFILLp(ary) + 1 - (offset + length);
2872     if (after < 0) {                            /* not that much array */
2873         length += after;                        /* offset+length now in array */
2874         after = 0;
2875         if (!AvALLOC(ary))
2876             av_extend(ary, 0);
2877     }
2878
2879     /* At this point, MARK .. SP-1 is our new LIST */
2880
2881     newlen = SP - MARK;
2882     diff = newlen - length;
2883     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2884         av_reify(ary);
2885
2886     if (diff < 0) {                             /* shrinking the area */
2887         if (newlen) {
2888             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2889             Copy(MARK, tmparyval, newlen, SV*);
2890         }
2891
2892         MARK = ORIGMARK + 1;
2893         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2894             MEXTEND(MARK, length);
2895             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2896             if (AvREAL(ary)) {
2897                 EXTEND_MORTAL(length);
2898                 for (i = length, dst = MARK; i; i--) {
2899                     sv_2mortal(*dst);   /* free them eventualy */
2900                     dst++;
2901                 }
2902             }
2903             MARK += length - 1;
2904         }
2905         else {
2906             *MARK = AvARRAY(ary)[offset+length-1];
2907             if (AvREAL(ary)) {
2908                 sv_2mortal(*MARK);
2909                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2910                     SvREFCNT_dec(*dst++);       /* free them now */
2911             }
2912         }
2913         AvFILLp(ary) += diff;
2914
2915         /* pull up or down? */
2916
2917         if (offset < after) {                   /* easier to pull up */
2918             if (offset) {                       /* esp. if nothing to pull */
2919                 src = &AvARRAY(ary)[offset-1];
2920                 dst = src - diff;               /* diff is negative */
2921                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2922                     *dst-- = *src--;
2923             }
2924             dst = AvARRAY(ary);
2925             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2926             AvMAX(ary) += diff;
2927         }
2928         else {
2929             if (after) {                        /* anything to pull down? */
2930                 src = AvARRAY(ary) + offset + length;
2931                 dst = src + diff;               /* diff is negative */
2932                 Move(src, dst, after, SV*);
2933             }
2934             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2935                                                 /* avoid later double free */
2936         }
2937         i = -diff;
2938         while (i)
2939             dst[--i] = &PL_sv_undef;
2940
2941         if (newlen) {
2942             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2943               newlen; newlen--) {
2944                 *dst = NEWSV(46, 0);
2945                 sv_setsv(*dst++, *src++);
2946             }
2947             Safefree(tmparyval);
2948         }
2949     }
2950     else {                                      /* no, expanding (or same) */
2951         if (length) {
2952             New(452, tmparyval, length, SV*);   /* so remember deletion */
2953             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2954         }
2955
2956         if (diff > 0) {                         /* expanding */
2957
2958             /* push up or down? */
2959
2960             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2961                 if (offset) {
2962                     src = AvARRAY(ary);
2963                     dst = src - diff;
2964                     Move(src, dst, offset, SV*);
2965                 }
2966                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2967                 AvMAX(ary) += diff;
2968                 AvFILLp(ary) += diff;
2969             }
2970             else {
2971                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2972                     av_extend(ary, AvFILLp(ary) + diff);
2973                 AvFILLp(ary) += diff;
2974
2975                 if (after) {
2976                     dst = AvARRAY(ary) + AvFILLp(ary);
2977                     src = dst - diff;
2978                     for (i = after; i; i--) {
2979                         *dst-- = *src--;
2980                     }
2981                 }
2982             }
2983         }
2984
2985         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2986             *dst = NEWSV(46, 0);
2987             sv_setsv(*dst++, *src++);
2988         }
2989         MARK = ORIGMARK + 1;
2990         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2991             if (length) {
2992                 Copy(tmparyval, MARK, length, SV*);
2993                 if (AvREAL(ary)) {
2994                     EXTEND_MORTAL(length);
2995                     for (i = length, dst = MARK; i; i--) {
2996                         sv_2mortal(*dst);       /* free them eventualy */
2997                         dst++;
2998                     }
2999                 }
3000                 Safefree(tmparyval);
3001             }
3002             MARK += length - 1;
3003         }
3004         else if (length--) {
3005             *MARK = tmparyval[length];
3006             if (AvREAL(ary)) {
3007                 sv_2mortal(*MARK);
3008                 while (length-- > 0)
3009                     SvREFCNT_dec(tmparyval[length]);
3010             }
3011             Safefree(tmparyval);
3012         }
3013         else
3014             *MARK = &PL_sv_undef;
3015     }
3016     SP = MARK;
3017     RETURN;
3018 }
3019
3020 PP(pp_push)
3021 {
3022     djSP; dMARK; dORIGMARK; dTARGET;
3023     register AV *ary = (AV*)*++MARK;
3024     register SV *sv = &PL_sv_undef;
3025     MAGIC *mg;
3026
3027     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3028         *MARK-- = SvTIED_obj((SV*)ary, mg);
3029         PUSHMARK(MARK);
3030         PUTBACK;
3031         ENTER;
3032         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3033         LEAVE;
3034         SPAGAIN;
3035     }
3036     else {
3037         /* Why no pre-extend of ary here ? */
3038         for (++MARK; MARK <= SP; MARK++) {
3039             sv = NEWSV(51, 0);
3040             if (*MARK)
3041                 sv_setsv(sv, *MARK);
3042             av_push(ary, sv);
3043         }
3044     }
3045     SP = ORIGMARK;
3046     PUSHi( AvFILL(ary) + 1 );
3047     RETURN;
3048 }
3049
3050 PP(pp_pop)
3051 {
3052     djSP;
3053     AV *av = (AV*)POPs;
3054     SV *sv = av_pop(av);
3055     if (AvREAL(av))
3056         (void)sv_2mortal(sv);
3057     PUSHs(sv);
3058     RETURN;
3059 }
3060
3061 PP(pp_shift)
3062 {
3063     djSP;
3064     AV *av = (AV*)POPs;
3065     SV *sv = av_shift(av);
3066     EXTEND(SP, 1);
3067     if (!sv)
3068         RETPUSHUNDEF;
3069     if (AvREAL(av))
3070         (void)sv_2mortal(sv);
3071     PUSHs(sv);
3072     RETURN;
3073 }
3074
3075 PP(pp_unshift)
3076 {
3077     djSP; dMARK; dORIGMARK; dTARGET;
3078     register AV *ary = (AV*)*++MARK;
3079     register SV *sv;
3080     register I32 i = 0;
3081     MAGIC *mg;
3082
3083     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3084         *MARK-- = SvTIED_obj((SV*)ary, mg);
3085         PUSHMARK(MARK);
3086         PUTBACK;
3087         ENTER;
3088         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3089         LEAVE;
3090         SPAGAIN;
3091     }
3092     else {
3093         av_unshift(ary, SP - MARK);
3094         while (MARK < SP) {
3095             sv = NEWSV(27, 0);
3096             sv_setsv(sv, *++MARK);
3097             (void)av_store(ary, i++, sv);
3098         }
3099     }
3100     SP = ORIGMARK;
3101     PUSHi( AvFILL(ary) + 1 );
3102     RETURN;
3103 }
3104
3105 PP(pp_reverse)
3106 {
3107     djSP; dMARK;
3108     register SV *tmp;
3109     SV **oldsp = SP;
3110
3111     if (GIMME == G_ARRAY) {
3112         MARK++;
3113         while (MARK < SP) {
3114             tmp = *MARK;
3115             *MARK++ = *SP;
3116             *SP-- = tmp;
3117         }
3118         SP = oldsp;
3119     }
3120     else {
3121         register char *up;
3122         register char *down;
3123         register I32 tmp;
3124         dTARGET;
3125         STRLEN len;
3126
3127         if (SP - MARK > 1)
3128             do_join(TARG, &PL_sv_no, MARK, SP);
3129         else
3130             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3131         up = SvPV_force(TARG, len);
3132         if (len > 1) {
3133             if (IN_UTF8) {      /* first reverse each character */
3134                 U8* s = (U8*)SvPVX(TARG);
3135                 U8* send = (U8*)(s + len);
3136                 while (s < send) {
3137                     if (*s < 0x80) {
3138                         s++;
3139                         continue;
3140                     }
3141                     else {
3142                         up = (char*)s;
3143                         s += UTF8SKIP(s);
3144                         down = (char*)(s - 1);
3145                         if (s > send || !((*down & 0xc0) == 0x80)) {
3146                             warn("Malformed UTF-8 character");
3147                             break;
3148                         }
3149                         while (down > up) {
3150                             tmp = *up;
3151                             *up++ = *down;
3152                             *down-- = tmp;
3153                         }
3154                     }
3155                 }
3156                 up = SvPVX(TARG);
3157             }
3158             down = SvPVX(TARG) + len - 1;
3159             while (down > up) {
3160                 tmp = *up;
3161                 *up++ = *down;
3162                 *down-- = tmp;
3163             }
3164             (void)SvPOK_only(TARG);
3165         }
3166         SP = MARK + 1;
3167         SETTARG;
3168     }
3169     RETURN;
3170 }
3171
3172 STATIC SV      *
3173 mul128(SV *sv, U8 m)
3174 {
3175   STRLEN          len;
3176   char           *s = SvPV(sv, len);
3177   char           *t;
3178   U32             i = 0;
3179
3180   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3181     SV             *tmpNew = newSVpv("0000000000", 10);
3182
3183     sv_catsv(tmpNew, sv);
3184     SvREFCNT_dec(sv);           /* free old sv */
3185     sv = tmpNew;
3186     s = SvPV(sv, len);
3187   }
3188   t = s + len - 1;
3189   while (!*t)                   /* trailing '\0'? */
3190     t--;
3191   while (t > s) {
3192     i = ((*t - '0') << 7) + m;
3193     *(t--) = '0' + (i % 10);
3194     m = i / 10;
3195   }
3196   return (sv);
3197 }
3198
3199 /* Explosives and implosives. */
3200
3201 #if 'I' == 73 && 'J' == 74
3202 /* On an ASCII/ISO kind of system */
3203 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3204 #else
3205 /*
3206   Some other sort of character set - use memchr() so we don't match
3207   the null byte.
3208  */
3209 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3210 #endif
3211
3212 PP(pp_unpack)
3213 {
3214     djSP;
3215     dPOPPOPssrl;
3216     SV **oldsp = SP;
3217     I32 gimme = GIMME_V;
3218     SV *sv;
3219     STRLEN llen;
3220     STRLEN rlen;
3221     register char *pat = SvPV(left, llen);
3222     register char *s = SvPV(right, rlen);
3223     char *strend = s + rlen;
3224     char *strbeg = s;
3225     register char *patend = pat + llen;
3226     I32 datumtype;
3227     register I32 len;
3228     register I32 bits;
3229
3230     /* These must not be in registers: */
3231     I16 ashort;
3232     int aint;
3233     I32 along;
3234 #ifdef HAS_QUAD
3235     Quad_t aquad;
3236 #endif
3237     U16 aushort;
3238     unsigned int auint;
3239     U32 aulong;
3240 #ifdef HAS_QUAD
3241     Uquad_t auquad;
3242 #endif
3243     char *aptr;
3244     float afloat;
3245     double adouble;
3246     I32 checksum = 0;
3247     register U32 culong;
3248     double cdouble;
3249     int commas = 0;
3250 #ifdef PERL_NATINT_PACK
3251     int natint;         /* native integer */
3252     int unatint;        /* unsigned native integer */
3253 #endif
3254
3255     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3256         /*SUPPRESS 530*/
3257         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3258         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3259             patend++;
3260             while (isDIGIT(*patend) || *patend == '*')
3261                 patend++;
3262         }
3263         else
3264             patend++;
3265     }
3266     while (pat < patend) {
3267       reparse:
3268         datumtype = *pat++ & 0xFF;
3269 #ifdef PERL_NATINT_PACK
3270         natint = 0;
3271 #endif
3272         if (isSPACE(datumtype))
3273             continue;
3274         if (*pat == '_') {
3275             char *natstr = "sSiIlL";
3276
3277             if (strchr(natstr, datumtype)) {
3278 #ifdef PERL_NATINT_PACK
3279                 natint = 1;
3280 #endif
3281                 pat++;
3282             }
3283             else
3284                 croak("'_' allowed only after types %s", natstr);
3285         }
3286         if (pat >= patend)
3287             len = 1;
3288         else if (*pat == '*') {
3289             len = strend - strbeg;      /* long enough */
3290             pat++;
3291         }
3292         else if (isDIGIT(*pat)) {
3293             len = *pat++ - '0';
3294             while (isDIGIT(*pat))
3295                 len = (len * 10) + (*pat++ - '0');
3296         }
3297         else
3298             len = (datumtype != '@');
3299         switch(datumtype) {
3300         default:
3301             croak("Invalid type in unpack: '%c'", (int)datumtype);
3302         case ',': /* grandfather in commas but with a warning */
3303             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3304                 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3305             break;
3306         case '%':
3307             if (len == 1 && pat[-1] != '1')
3308                 len = 16;
3309             checksum = len;
3310             culong = 0;
3311             cdouble = 0;
3312             if (pat < patend)
3313                 goto reparse;
3314             break;
3315         case '@':
3316             if (len > strend - strbeg)
3317                 DIE("@ outside of string");
3318             s = strbeg + len;
3319             break;
3320         case 'X':
3321             if (len > s - strbeg)
3322                 DIE("X outside of string");
3323             s -= len;
3324             break;
3325         case 'x':
3326             if (len > strend - s)
3327                 DIE("x outside of string");
3328             s += len;
3329             break;
3330         case 'A':
3331         case 'Z':
3332         case 'a':
3333             if (len > strend - s)
3334                 len = strend - s;
3335             if (checksum)
3336                 goto uchar_checksum;
3337             sv = NEWSV(35, len);
3338             sv_setpvn(sv, s, len);
3339             s += len;
3340             if (datumtype == 'A' || datumtype == 'Z') {
3341                 aptr = s;       /* borrow register */
3342                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3343                     s = SvPVX(sv);
3344                     while (*s)
3345                         s++;
3346                 }
3347                 else {          /* 'A' strips both nulls and spaces */
3348                     s = SvPVX(sv) + len - 1;
3349                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3350                         s--;
3351                     *++s = '\0';
3352                 }
3353                 SvCUR_set(sv, s - SvPVX(sv));
3354                 s = aptr;       /* unborrow register */
3355             }
3356             XPUSHs(sv_2mortal(sv));
3357             break;
3358         case 'B':
3359         case 'b':
3360             if (pat[-1] == '*' || len > (strend - s) * 8)
3361                 len = (strend - s) * 8;
3362             if (checksum) {
3363                 if (!PL_bitcount) {
3364                     Newz(601, PL_bitcount, 256, char);
3365                     for (bits = 1; bits < 256; bits++) {
3366                         if (bits & 1)   PL_bitcount[bits]++;
3367                         if (bits & 2)   PL_bitcount[bits]++;
3368                         if (bits & 4)   PL_bitcount[bits]++;
3369                         if (bits & 8)   PL_bitcount[bits]++;
3370                         if (bits & 16)  PL_bitcount[bits]++;
3371                         if (bits & 32)  PL_bitcount[bits]++;
3372                         if (bits & 64)  PL_bitcount[bits]++;
3373                         if (bits & 128) PL_bitcount[bits]++;
3374                     }
3375                 }
3376                 while (len >= 8) {
3377                     culong += PL_bitcount[*(unsigned char*)s++];
3378                     len -= 8;
3379                 }
3380                 if (len) {
3381                     bits = *s;
3382                     if (datumtype == 'b') {
3383                         while (len-- > 0) {
3384                             if (bits & 1) culong++;
3385                             bits >>= 1;
3386                         }
3387                     }
3388                     else {
3389                         while (len-- > 0) {
3390                             if (bits & 128) culong++;
3391                             bits <<= 1;
3392                         }
3393                     }
3394                 }
3395                 break;
3396             }
3397             sv = NEWSV(35, len + 1);
3398             SvCUR_set(sv, len);
3399             SvPOK_on(sv);
3400             aptr = pat;                 /* borrow register */
3401             pat = SvPVX(sv);
3402             if (datumtype == 'b') {
3403                 aint = len;
3404                 for (len = 0; len < aint; len++) {
3405                     if (len & 7)                /*SUPPRESS 595*/
3406                         bits >>= 1;
3407                     else
3408                         bits = *s++;
3409                     *pat++ = '0' + (bits & 1);
3410                 }
3411             }
3412             else {
3413                 aint = len;
3414                 for (len = 0; len < aint; len++) {
3415                     if (len & 7)
3416                         bits <<= 1;
3417                     else
3418                         bits = *s++;
3419                     *pat++ = '0' + ((bits & 128) != 0);
3420                 }
3421             }
3422             *pat = '\0';
3423             pat = aptr;                 /* unborrow register */
3424             XPUSHs(sv_2mortal(sv));
3425             break;
3426         case 'H':
3427         case 'h':
3428             if (pat[-1] == '*' || len > (strend - s) * 2)
3429                 len = (strend - s) * 2;
3430             sv = NEWSV(35, len + 1);
3431             SvCUR_set(sv, len);
3432             SvPOK_on(sv);
3433             aptr = pat;                 /* borrow register */
3434             pat = SvPVX(sv);
3435             if (datumtype == 'h') {
3436                 aint = len;
3437                 for (len = 0; len < aint; len++) {
3438                     if (len & 1)
3439                         bits >>= 4;
3440                     else
3441                         bits = *s++;
3442                     *pat++ = PL_hexdigit[bits & 15];
3443                 }
3444             }
3445             else {
3446                 aint = len;
3447                 for (len = 0; len < aint; len++) {
3448                     if (len & 1)
3449                         bits <<= 4;
3450                     else
3451                         bits = *s++;
3452                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3453                 }
3454             }
3455             *pat = '\0';
3456             pat = aptr;                 /* unborrow register */
3457             XPUSHs(sv_2mortal(sv));
3458             break;
3459         case 'c':
3460             if (len > strend - s)
3461                 len = strend - s;
3462             if (checksum) {
3463                 while (len-- > 0) {
3464                     aint = *s++;
3465                     if (aint >= 128)    /* fake up signed chars */
3466                         aint -= 256;
3467                     culong += aint;
3468                 }
3469             }
3470             else {
3471                 EXTEND(SP, len);
3472                 EXTEND_MORTAL(len);
3473                 while (len-- > 0) {
3474                     aint = *s++;
3475                     if (aint >= 128)    /* fake up signed chars */
3476                         aint -= 256;
3477                     sv = NEWSV(36, 0);
3478                     sv_setiv(sv, (IV)aint);
3479                     PUSHs(sv_2mortal(sv));
3480                 }
3481             }
3482             break;
3483         case 'C':
3484             if (len > strend - s)
3485                 len = strend - s;
3486             if (checksum) {
3487               uchar_checksum:
3488                 while (len-- > 0) {
3489                     auint = *s++ & 255;
3490                     culong += auint;
3491                 }
3492             }
3493             else {
3494                 EXTEND(SP, len);
3495                 EXTEND_MORTAL(len);
3496                 while (len-- > 0) {
3497                     auint = *s++ & 255;
3498                     sv = NEWSV(37, 0);
3499                     sv_setiv(sv, (IV)auint);
3500                     PUSHs(sv_2mortal(sv));
3501                 }
3502             }
3503             break;
3504         case 'U':
3505             if (len > strend - s)
3506                 len = strend - s;
3507             if (checksum) {
3508                 while (len-- > 0 && s < strend) {
3509                     auint = utf8_to_uv((U8*)s, &along);
3510                     s += along;
3511                     if (checksum > 32)
3512                         cdouble += (double)auint;
3513                     else
3514                         culong += auint;
3515                 }
3516             }
3517             else {
3518                 EXTEND(SP, len);
3519                 EXTEND_MORTAL(len);
3520                 while (len-- > 0 && s < strend) {
3521                     auint = utf8_to_uv((U8*)s, &along);
3522                     s += along;
3523                     sv = NEWSV(37, 0);
3524                     sv_setuv(sv, (UV)auint);
3525                     PUSHs(sv_2mortal(sv));
3526                 }
3527             }
3528             break;
3529         case 's':
3530 #if SHORTSIZE == SIZE16
3531             along = (strend - s) / SIZE16;
3532 #else
3533             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3534 #endif
3535             if (len > along)
3536                 len = along;
3537             if (checksum) {
3538 #if SHORTSIZE != SIZE16
3539                 if (natint) {
3540                     while (len-- > 0) {
3541                         COPYNN(s, &ashort, sizeof(short));
3542                         s += sizeof(short);
3543                         culong += ashort;
3544
3545                     }
3546                 }
3547                 else
3548 #endif
3549                 {
3550                     while (len-- > 0) {
3551                         COPY16(s, &ashort);
3552                         s += SIZE16;
3553                         culong += ashort;
3554                     }
3555                 }
3556             }
3557             else {
3558                 EXTEND(SP, len);
3559                 EXTEND_MORTAL(len);
3560 #if SHORTSIZE != SIZE16
3561                 if (natint) {
3562                     while (len-- > 0) {
3563                         COPYNN(s, &ashort, sizeof(short));
3564                         s += sizeof(short);
3565                         sv = NEWSV(38, 0);
3566                         sv_setiv(sv, (IV)ashort);
3567                         PUSHs(sv_2mortal(sv));
3568                     }
3569                 }
3570                 else
3571 #endif
3572                 {
3573                     while (len-- > 0) {
3574                         COPY16(s, &ashort);
3575                         s += SIZE16;
3576                         sv = NEWSV(38, 0);
3577                         sv_setiv(sv, (IV)ashort);
3578                         PUSHs(sv_2mortal(sv));
3579                     }
3580                 }
3581             }
3582             break;
3583         case 'v':
3584         case 'n':
3585         case 'S':
3586 #if SHORTSIZE == SIZE16
3587             along = (strend - s) / SIZE16;
3588 #else
3589             unatint = natint && datumtype == 'S';
3590             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3591 #endif
3592             if (len > along)
3593                 len = along;
3594             if (checksum) {
3595 #if SHORTSIZE != SIZE16
3596                 if (unatint) {
3597                     while (len-- > 0) {
3598                         COPYNN(s, &aushort, sizeof(unsigned short));
3599                         s += sizeof(unsigned short);
3600                         culong += aushort;
3601                     }
3602                 }
3603                 else
3604 #endif
3605                 {
3606                     while (len-- > 0) {
3607                         COPY16(s, &aushort);
3608                         s += SIZE16;
3609 #ifdef HAS_NTOHS
3610                         if (datumtype == 'n')
3611                             aushort = PerlSock_ntohs(aushort);
3612 #endif
3613 #ifdef HAS_VTOHS
3614                         if (datumtype == 'v')
3615                             aushort = vtohs(aushort);
3616 #endif
3617                         culong += aushort;
3618                     }
3619                 }
3620             }
3621             else {
3622                 EXTEND(SP, len);
3623                 EXTEND_MORTAL(len);
3624 #if SHORTSIZE != SIZE16
3625                 if (unatint) {
3626                     while (len-- > 0) {
3627                         COPYNN(s, &aushort, sizeof(unsigned short));
3628                         s += sizeof(unsigned short);
3629                         sv = NEWSV(39, 0);
3630                         sv_setiv(sv, (UV)aushort);
3631                         PUSHs(sv_2mortal(sv));
3632                     }
3633                 }
3634                 else
3635 #endif
3636                 {
3637                     while (len-- > 0) {
3638                         COPY16(s, &aushort);
3639                         s += SIZE16;
3640                         sv = NEWSV(39, 0);
3641 #ifdef HAS_NTOHS
3642                         if (datumtype == 'n')
3643                             aushort = PerlSock_ntohs(aushort);
3644 #endif
3645 #ifdef HAS_VTOHS
3646                         if (datumtype == 'v')
3647                             aushort = vtohs(aushort);
3648 #endif
3649                         sv_setiv(sv, (UV)aushort);
3650                         PUSHs(sv_2mortal(sv));
3651                     }
3652                 }
3653             }
3654             break;
3655         case 'i':
3656             along = (strend - s) / sizeof(int);
3657             if (len > along)
3658                 len = along;
3659             if (checksum) {
3660                 while (len-- > 0) {
3661                     Copy(s, &aint, 1, int);
3662                     s += sizeof(int);
3663                     if (checksum > 32)
3664                         cdouble += (double)aint;
3665                     else
3666                         culong += aint;
3667                 }
3668             }
3669             else {
3670                 EXTEND(SP, len);
3671                 EXTEND_MORTAL(len);
3672                 while (len-- > 0) {
3673                     Copy(s, &aint, 1, int);
3674                     s += sizeof(int);
3675                     sv = NEWSV(40, 0);
3676 #ifdef __osf__
3677                     /* Without the dummy below unpack("i", pack("i",-1))
3678                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3679                      * cc with optimization turned on */
3680                     (aint) ?
3681                         sv_setiv(sv, (IV)aint) :
3682 #endif
3683                     sv_setiv(sv, (IV)aint);
3684                     PUSHs(sv_2mortal(sv));
3685                 }
3686             }
3687             break;
3688         case 'I':
3689             along = (strend - s) / sizeof(unsigned int);
3690             if (len > along)
3691                 len = along;
3692             if (checksum) {
3693                 while (len-- > 0) {
3694                     Copy(s, &auint, 1, unsigned int);
3695                     s += sizeof(unsigned int);
3696                     if (checksum > 32)
3697                         cdouble += (double)auint;
3698                     else
3699                         culong += auint;
3700                 }
3701             }
3702             else {
3703                 EXTEND(SP, len);
3704                 EXTEND_MORTAL(len);
3705                 while (len-- > 0) {
3706                     Copy(s, &auint, 1, unsigned int);
3707                     s += sizeof(unsigned int);
3708                     sv = NEWSV(41, 0);
3709 #ifdef __osf__
3710                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3711                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3712                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3713                      * with optimization turned on.
3714                      * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3715                      * does not have this problem even with -O4)
3716                      */
3717                     (auint) ?
3718                         sv_setuv(sv, (UV)auint) :
3719 #endif
3720                     sv_setuv(sv, (UV)auint);
3721                     PUSHs(sv_2mortal(sv));
3722                 }
3723             }
3724             break;
3725         case 'l':
3726 #if LONGSIZE == SIZE32
3727             along = (strend - s) / SIZE32;
3728 #else
3729             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3730 #endif
3731             if (len > along)
3732                 len = along;
3733             if (checksum) {
3734 #if LONGSIZE != SIZE32
3735                 if (natint) {
3736                     while (len-- > 0) {
3737                         COPYNN(s, &along, sizeof(long));
3738                         s += sizeof(long);
3739                         if (checksum > 32)
3740                             cdouble += (double)along;
3741                         else
3742                             culong += along;
3743                     }
3744                 }
3745                 else
3746 #endif
3747                 {
3748                     while (len-- > 0) {
3749                         COPY32(s, &along);
3750                         s += SIZE32;
3751                         if (checksum > 32)
3752                             cdouble += (double)along;
3753                         else
3754                             culong += along;
3755                     }
3756                 }
3757             }
3758             else {
3759                 EXTEND(SP, len);
3760                 EXTEND_MORTAL(len);
3761 #if LONGSIZE != SIZE32
3762                 if (natint) {
3763                     while (len-- > 0) {
3764                         COPYNN(s, &along, sizeof(long));
3765                         s += sizeof(long);
3766                         sv = NEWSV(42, 0);
3767                         sv_setiv(sv, (IV)along);
3768                         PUSHs(sv_2mortal(sv));
3769                     }
3770                 }
3771                 else
3772 #endif
3773                 {
3774                     while (len-- > 0) {
3775                         COPY32(s, &along);
3776                         s += SIZE32;
3777                         sv = NEWSV(42, 0);
3778                         sv_setiv(sv, (IV)along);
3779                         PUSHs(sv_2mortal(sv));
3780                     }
3781                 }
3782             }
3783             break;
3784         case 'V':
3785         case 'N':
3786         case 'L':
3787 #if LONGSIZE == SIZE32
3788             along = (strend - s) / SIZE32;
3789 #else
3790             unatint = natint && datumtype == 'L';
3791             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3792 #endif
3793             if (len > along)
3794                 len = along;
3795             if (checksum) {
3796 #if LONGSIZE != SIZE32
3797                 if (unatint) {
3798                     while (len-- > 0) {
3799                         COPYNN(s, &aulong, sizeof(unsigned long));
3800                         s += sizeof(unsigned long);
3801                         if (checksum > 32)
3802                             cdouble += (double)aulong;
3803                         else
3804                             culong += aulong;
3805                     }
3806                 }
3807                 else
3808 #endif
3809                 {
3810                     while (len-- > 0) {
3811                         COPY32(s, &aulong);
3812                         s += SIZE32;
3813 #ifdef HAS_NTOHL
3814                         if (datumtype == 'N')
3815                             aulong = PerlSock_ntohl(aulong);
3816 #endif
3817 #ifdef HAS_VTOHL
3818                         if (datumtype == 'V')
3819                             aulong = vtohl(aulong);
3820 #endif
3821                         if (checksum > 32)
3822                             cdouble += (double)aulong;
3823                         else
3824                             culong += aulong;
3825                     }
3826                 }
3827             }
3828             else {
3829                 EXTEND(SP, len);
3830                 EXTEND_MORTAL(len);
3831 #if LONGSIZE != SIZE32
3832                 if (unatint) {
3833                     while (len-- > 0) {
3834                         COPYNN(s, &aulong, sizeof(unsigned long));
3835                         s += sizeof(unsigned long);
3836                         sv = NEWSV(43, 0);
3837                         sv_setuv(sv, (UV)aulong);
3838                         PUSHs(sv_2mortal(sv));
3839                     }
3840                 }
3841                 else
3842 #endif
3843                 {
3844                     while (len-- > 0) {
3845                         COPY32(s, &aulong);
3846                         s += SIZE32;
3847 #ifdef HAS_NTOHL
3848                         if (datumtype == 'N')
3849                             aulong = PerlSock_ntohl(aulong);
3850 #endif
3851 #ifdef HAS_VTOHL
3852                         if (datumtype == 'V')
3853                             aulong = vtohl(aulong);
3854 #endif
3855                         sv = NEWSV(43, 0);
3856                         sv_setuv(sv, (UV)aulong);
3857                         PUSHs(sv_2mortal(sv));
3858                     }
3859                 }
3860             }
3861             break;
3862         case 'p':
3863             along = (strend - s) / sizeof(char*);
3864             if (len > along)
3865                 len = along;
3866             EXTEND(SP, len);
3867             EXTEND_MORTAL(len);
3868             while (len-- > 0) {
3869                 if (sizeof(char*) > strend - s)
3870                     break;
3871                 else {
3872                     Copy(s, &aptr, 1, char*);
3873                     s += sizeof(char*);
3874                 }
3875                 sv = NEWSV(44, 0);
3876                 if (aptr)
3877                     sv_setpv(sv, aptr);
3878                 PUSHs(sv_2mortal(sv));
3879             }
3880             break;
3881         case 'w':
3882             EXTEND(SP, len);
3883             EXTEND_MORTAL(len);
3884             {
3885                 UV auv = 0;
3886                 U32 bytes = 0;
3887
3888                 while ((len > 0) && (s < strend)) {
3889                     auv = (auv << 7) | (*s & 0x7f);
3890                     if (!(*s++ & 0x80)) {
3891                         bytes = 0;
3892                         sv = NEWSV(40, 0);
3893                         sv_setuv(sv, auv);
3894                         PUSHs(sv_2mortal(sv));
3895                         len--;
3896                         auv = 0;
3897                     }
3898                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3899                         char *t;
3900                         STRLEN n_a;
3901
3902                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3903                         while (s < strend) {
3904                             sv = mul128(sv, *s & 0x7f);
3905                             if (!(*s++ & 0x80)) {
3906                                 bytes = 0;
3907                                 break;
3908                             }
3909                         }
3910                         t = SvPV(sv, n_a);
3911                         while (*t == '0')
3912                             t++;
3913                         sv_chop(sv, t);
3914                         PUSHs(sv_2mortal(sv));
3915                         len--;
3916                         auv = 0;
3917                     }
3918                 }
3919                 if ((s >= strend) && bytes)
3920                     croak("Unterminated compressed integer");
3921             }
3922             break;
3923         case 'P':
3924             EXTEND(SP, 1);
3925             if (sizeof(char*) > strend - s)
3926                 break;
3927             else {
3928                 Copy(s, &aptr, 1, char*);
3929                 s += sizeof(char*);
3930             }
3931             sv = NEWSV(44, 0);
3932             if (aptr)
3933                 sv_setpvn(sv, aptr, len);
3934             PUSHs(sv_2mortal(sv));
3935             break;
3936 #ifdef HAS_QUAD
3937         case 'q':
3938             along = (strend - s) / sizeof(Quad_t);
3939             if (len > along)
3940                 len = along;
3941             EXTEND(SP, len);
3942             EXTEND_MORTAL(len);
3943             while (len-- > 0) {
3944                 if (s + sizeof(Quad_t) > strend)
3945                     aquad = 0;
3946                 else {
3947                     Copy(s, &aquad, 1, Quad_t);
3948                     s += sizeof(Quad_t);
3949                 }
3950                 sv = NEWSV(42, 0);
3951                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3952                     sv_setiv(sv, (IV)aquad);
3953                 else
3954                     sv_setnv(sv, (double)aquad);
3955                 PUSHs(sv_2mortal(sv));
3956             }
3957             break;
3958         case 'Q':
3959             along = (strend - s) / sizeof(Quad_t);
3960             if (len > along)
3961                 len = along;
3962             EXTEND(SP, len);
3963             EXTEND_MORTAL(len);
3964             while (len-- > 0) {
3965                 if (s + sizeof(Uquad_t) > strend)
3966                     auquad = 0;
3967                 else {
3968                     Copy(s, &auquad, 1, Uquad_t);
3969                     s += sizeof(Uquad_t);
3970                 }
3971                 sv = NEWSV(43, 0);
3972                 if (auquad <= UV_MAX)
3973                     sv_setuv(sv, (UV)auquad);
3974                 else
3975                     sv_setnv(sv, (double)auquad);
3976                 PUSHs(sv_2mortal(sv));
3977             }
3978             break;
3979 #endif
3980         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3981         case 'f':
3982         case 'F':
3983             along = (strend - s) / sizeof(float);
3984             if (len > along)
3985                 len = along;
3986             if (checksum) {
3987                 while (len-- > 0) {
3988                     Copy(s, &afloat, 1, float);
3989                     s += sizeof(float);
3990                     cdouble += afloat;
3991                 }
3992             }
3993             else {
3994                 EXTEND(SP, len);
3995                 EXTEND_MORTAL(len);
3996                 while (len-- > 0) {
3997                     Copy(s, &afloat, 1, float);
3998                     s += sizeof(float);
3999                     sv = NEWSV(47, 0);
4000                     sv_setnv(sv, (double)afloat);
4001                     PUSHs(sv_2mortal(sv));
4002                 }
4003             }
4004             break;
4005         case 'd':
4006         case 'D':
4007             along = (strend - s) / sizeof(double);
4008             if (len > along)
4009                 len = along;
4010             if (checksum) {
4011                 while (len-- > 0) {
4012                     Copy(s, &adouble, 1, double);
4013                     s += sizeof(double);
4014                     cdouble += adouble;
4015                 }
4016             }
4017             else {
4018                 EXTEND(SP, len);
4019                 EXTEND_MORTAL(len);
4020                 while (len-- > 0) {
4021                     Copy(s, &adouble, 1, double);
4022                     s += sizeof(double);
4023                     sv = NEWSV(48, 0);
4024                     sv_setnv(sv, (double)adouble);
4025                     PUSHs(sv_2mortal(sv));
4026                 }
4027             }
4028             break;
4029         case 'u':
4030             /* MKS:
4031              * Initialise the decode mapping.  By using a table driven
4032              * algorithm, the code will be character-set independent
4033              * (and just as fast as doing character arithmetic)
4034              */
4035             if (PL_uudmap['M'] == 0) {
4036                 int i;
4037
4038                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4039                     PL_uudmap[PL_uuemap[i]] = i;
4040                 /*
4041                  * Because ' ' and '`' map to the same value,
4042                  * we need to decode them both the same.
4043                  */
4044                 PL_uudmap[' '] = 0;
4045             }
4046
4047             along = (strend - s) * 3 / 4;
4048             sv = NEWSV(42, along);
4049             if (along)
4050                 SvPOK_on(sv);
4051             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4052                 I32 a, b, c, d;
4053                 char hunk[4];
4054
4055                 hunk[3] = '\0';
4056                 len = PL_uudmap[*s++] & 077;
4057                 while (len > 0) {
4058                     if (s < strend && ISUUCHAR(*s))
4059                         a = PL_uudmap[*s++] & 077;
4060                     else
4061                         a = 0;
4062                     if (s < strend && ISUUCHAR(*s))
4063                         b = PL_uudmap[*s++] & 077;
4064                     else
4065                         b = 0;
4066                     if (s < strend && ISUUCHAR(*s))
4067                         c = PL_uudmap[*s++] & 077;
4068                     else
4069                         c = 0;
4070                     if (s < strend && ISUUCHAR(*s))
4071                         d = PL_uudmap[*s++] & 077;
4072                     else
4073                         d = 0;
4074                     hunk[0] = (a << 2) | (b >> 4);
4075                     hunk[1] = (b << 4) | (c >> 2);
4076                     hunk[2] = (c << 6) | d;
4077                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4078                     len -= 3;
4079                 }
4080                 if (*s == '\n')
4081                     s++;
4082                 else if (s[1] == '\n')          /* possible checksum byte */
4083                     s += 2;
4084             }
4085             XPUSHs(sv_2mortal(sv));
4086             break;
4087         }
4088         if (checksum) {
4089             sv = NEWSV(42, 0);
4090             if (strchr("fFdD", datumtype) ||
4091               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4092                 double trouble;
4093
4094                 adouble = 1.0;
4095                 while (checksum >= 16) {
4096                     checksum -= 16;
4097                     adouble *= 65536.0;
4098                 }
4099                 while (checksum >= 4) {
4100                     checksum -= 4;
4101                     adouble *= 16.0;
4102                 }
4103                 while (checksum--)
4104                     adouble *= 2.0;
4105                 along = (1 << checksum) - 1;
4106                 while (cdouble < 0.0)
4107                     cdouble += adouble;
4108                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4109                 sv_setnv(sv, cdouble);
4110             }
4111             else {
4112                 if (checksum < 32) {
4113                     aulong = (1 << checksum) - 1;
4114                     culong &= aulong;
4115                 }
4116                 sv_setuv(sv, (UV)culong);
4117             }
4118             XPUSHs(sv_2mortal(sv));
4119             checksum = 0;
4120         }
4121     }
4122     if (SP == oldsp && gimme == G_SCALAR)
4123         PUSHs(&PL_sv_undef);
4124     RETURN;
4125 }
4126
4127 STATIC void
4128 doencodes(register SV *sv, register char *s, register I32 len)
4129 {
4130     char hunk[5];
4131
4132     *hunk = PL_uuemap[len];
4133     sv_catpvn(sv, hunk, 1);
4134     hunk[4] = '\0';
4135     while (len > 2) {
4136         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4137         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4138         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4139         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4140         sv_catpvn(sv, hunk, 4);
4141         s += 3;
4142         len -= 3;
4143     }
4144     if (len > 0) {
4145         char r = (len > 1 ? s[1] : '\0');
4146         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4147         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4148         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4149         hunk[3] = PL_uuemap[0];
4150         sv_catpvn(sv, hunk, 4);
4151     }
4152     sv_catpvn(sv, "\n", 1);
4153 }
4154
4155 STATIC SV      *
4156 is_an_int(char *s, STRLEN l)
4157 {
4158   STRLEN         n_a;
4159   SV             *result = newSVpv("", l);
4160   char           *result_c = SvPV(result, n_a); /* convenience */
4161   char           *out = result_c;
4162   bool            skip = 1;
4163   bool            ignore = 0;
4164
4165   while (*s) {
4166     switch (*s) {
4167     case ' ':
4168       break;
4169     case '+':
4170       if (!skip) {
4171         SvREFCNT_dec(result);
4172         return (NULL);
4173       }
4174       break;
4175     case '0':
4176     case '1':
4177     case '2':
4178     case '3':
4179     case '4':
4180     case '5':
4181     case '6':
4182     case '7':
4183     case '8':
4184     case '9':
4185       skip = 0;
4186       if (!ignore) {
4187         *(out++) = *s;
4188       }
4189       break;
4190     case '.':
4191       ignore = 1;
4192       break;
4193     default:
4194       SvREFCNT_dec(result);
4195       return (NULL);
4196     }
4197     s++;
4198   }
4199   *(out++) = '\0';
4200   SvCUR_set(result, out - result_c);
4201   return (result);
4202 }
4203
4204 STATIC int
4205 div128(SV *pnum, bool *done)
4206                                             /* must be '\0' terminated */
4207
4208 {
4209   STRLEN          len;
4210   char           *s = SvPV(pnum, len);
4211   int             m = 0;
4212   int             r = 0;
4213   char           *t = s;
4214
4215   *done = 1;
4216   while (*t) {
4217     int             i;
4218
4219     i = m * 10 + (*t - '0');
4220     m = i & 0x7F;
4221     r = (i >> 7);               /* r < 10 */
4222     if (r) {
4223       *done = 0;
4224     }
4225     *(t++) = '0' + r;
4226   }
4227   *(t++) = '\0';
4228   SvCUR_set(pnum, (STRLEN) (t - s));
4229   return (m);
4230 }
4231
4232
4233 PP(pp_pack)
4234 {
4235     djSP; dMARK; dORIGMARK; dTARGET;
4236     register SV *cat = TARG;
4237     register I32 items;
4238     STRLEN fromlen;
4239     register char *pat = SvPVx(*++MARK, fromlen);
4240     register char *patend = pat + fromlen;
4241     register I32 len;
4242     I32 datumtype;
4243     SV *fromstr;
4244     /*SUPPRESS 442*/
4245     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4246     static char *space10 = "          ";
4247
4248     /* These must not be in registers: */
4249     char achar;
4250     I16 ashort;
4251     int aint;
4252     unsigned int auint;
4253     I32 along;
4254     U32 aulong;
4255 #ifdef HAS_QUAD
4256     Quad_t aquad;
4257     Uquad_t auquad;
4258 #endif
4259     char *aptr;
4260     float afloat;
4261     double adouble;
4262     int commas = 0;
4263 #ifdef PERL_NATINT_PACK
4264     int natint;         /* native integer */
4265 #endif
4266
4267     items = SP - MARK;
4268     MARK++;
4269     sv_setpvn(cat, "", 0);
4270     while (pat < patend) {
4271 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4272         datumtype = *pat++ & 0xFF;
4273 #ifdef PERL_NATINT_PACK
4274         natint = 0;
4275 #endif
4276         if (isSPACE(datumtype))
4277             continue;
4278         if (*pat == '_') {
4279             char *natstr = "sSiIlL";
4280
4281             if (strchr(natstr, datumtype)) {
4282 #ifdef PERL_NATINT_PACK
4283                 natint = 1;
4284 #endif
4285                 pat++;
4286             }
4287             else
4288                 croak("'_' allowed only after types %s", natstr);
4289         }
4290         if (*pat == '*') {
4291             len = strchr("@Xxu", datumtype) ? 0 : items;
4292             pat++;
4293         }
4294         else if (isDIGIT(*pat)) {
4295             len = *pat++ - '0';
4296             while (isDIGIT(*pat))
4297                 len = (len * 10) + (*pat++ - '0');
4298         }
4299         else
4300             len = 1;
4301         switch(datumtype) {
4302         default:
4303             croak("Invalid type in pack: '%c'", (int)datumtype);
4304         case ',': /* grandfather in commas but with a warning */
4305             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4306                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4307             break;
4308         case '%':
4309             DIE("%% may only be used in unpack");
4310         case '@':
4311             len -= SvCUR(cat);
4312             if (len > 0)
4313                 goto grow;
4314             len = -len;
4315             if (len > 0)
4316                 goto shrink;
4317             break;
4318         case 'X':
4319           shrink:
4320             if (SvCUR(cat) < len)
4321                 DIE("X outside of string");
4322             SvCUR(cat) -= len;
4323             *SvEND(cat) = '\0';
4324             break;
4325         case 'x':
4326           grow:
4327             while (len >= 10) {
4328                 sv_catpvn(cat, null10, 10);
4329                 len -= 10;
4330             }
4331             sv_catpvn(cat, null10, len);
4332             break;
4333         case 'A':
4334         case 'Z':
4335         case 'a':
4336             fromstr = NEXTFROM;
4337             aptr = SvPV(fromstr, fromlen);
4338             if (pat[-1] == '*')
4339                 len = fromlen;
4340             if (fromlen > len)
4341                 sv_catpvn(cat, aptr, len);
4342             else {
4343                 sv_catpvn(cat, aptr, fromlen);
4344                 len -= fromlen;
4345                 if (datumtype == 'A') {
4346                     while (len >= 10) {
4347                         sv_catpvn(cat, space10, 10);
4348                         len -= 10;
4349                     }
4350                     sv_catpvn(cat, space10, len);
4351                 }
4352                 else {
4353                     while (len >= 10) {
4354                         sv_catpvn(cat, null10, 10);
4355                         len -= 10;
4356                     }
4357                     sv_catpvn(cat, null10, len);
4358                 }
4359             }
4360             break;
4361         case 'B':
4362         case 'b':
4363             {
4364                 char *savepat = pat;
4365                 I32 saveitems;
4366
4367                 fromstr = NEXTFROM;
4368                 saveitems = items;
4369                 aptr = SvPV(fromstr, fromlen);
4370                 if (pat[-1] == '*')
4371                     len = fromlen;
4372                 pat = aptr;
4373                 aint = SvCUR(cat);
4374                 SvCUR(cat) += (len+7)/8;
4375                 SvGROW(cat, SvCUR(cat) + 1);
4376                 aptr = SvPVX(cat) + aint;
4377                 if (len > fromlen)
4378                     len = fromlen;
4379                 aint = len;
4380                 items = 0;
4381                 if (datumtype == 'B') {
4382                     for (len = 0; len++ < aint;) {
4383                         items |= *pat++ & 1;
4384                         if (len & 7)
4385                             items <<= 1;
4386                         else {
4387                             *aptr++ = items & 0xff;
4388                             items = 0;
4389                         }
4390                     }
4391                 }
4392                 else {
4393                     for (len = 0; len++ < aint;) {
4394                         if (*pat++ & 1)
4395                             items |= 128;
4396                         if (len & 7)
4397                             items >>= 1;
4398                         else {
4399                             *aptr++ = items & 0xff;
4400                             items = 0;
4401                         }
4402                     }
4403                 }
4404                 if (aint & 7) {
4405                     if (datumtype == 'B')
4406                         items <<= 7 - (aint & 7);
4407                     else
4408                         items >>= 7 - (aint & 7);
4409                     *aptr++ = items & 0xff;
4410                 }
4411                 pat = SvPVX(cat) + SvCUR(cat);
4412                 while (aptr <= pat)
4413                     *aptr++ = '\0';
4414
4415                 pat = savepat;
4416                 items = saveitems;
4417             }
4418             break;
4419         case 'H':
4420         case 'h':
4421             {
4422                 char *savepat = pat;
4423                 I32 saveitems;
4424
4425                 fromstr = NEXTFROM;
4426                 saveitems = items;
4427                 aptr = SvPV(fromstr, fromlen);
4428                 if (pat[-1] == '*')
4429                     len = fromlen;
4430                 pat = aptr;
4431                 aint = SvCUR(cat);
4432                 SvCUR(cat) += (len+1)/2;
4433                 SvGROW(cat, SvCUR(cat) + 1);
4434                 aptr = SvPVX(cat) + aint;
4435                 if (len > fromlen)
4436                     len = fromlen;
4437                 aint = len;
4438                 items = 0;
4439                 if (datumtype == 'H') {
4440                     for (len = 0; len++ < aint;) {
4441                         if (isALPHA(*pat))
4442                             items |= ((*pat++ & 15) + 9) & 15;
4443                         else
4444                             items |= *pat++ & 15;
4445                         if (len & 1)
4446                             items <<= 4;
4447                         else {
4448                             *aptr++ = items & 0xff;
4449                             items = 0;
4450                         }
4451                     }
4452                 }
4453                 else {
4454                     for (len = 0; len++ < aint;) {
4455                         if (isALPHA(*pat))
4456                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4457                         else
4458                             items |= (*pat++ & 15) << 4;
4459                         if (len & 1)
4460                             items >>= 4;
4461                         else {
4462                             *aptr++ = items & 0xff;
4463                             items = 0;
4464                         }
4465                     }
4466                 }
4467                 if (aint & 1)
4468                     *aptr++ = items & 0xff;
4469                 pat = SvPVX(cat) + SvCUR(cat);
4470                 while (aptr <= pat)
4471                     *aptr++ = '\0';
4472
4473                 pat = savepat;
4474                 items = saveitems;
4475             }
4476             break;
4477         case 'C':
4478         case 'c':
4479             while (len-- > 0) {
4480                 fromstr = NEXTFROM;
4481                 aint = SvIV(fromstr);
4482                 achar = aint;
4483                 sv_catpvn(cat, &achar, sizeof(char));
4484             }
4485             break;
4486         case 'U':
4487             while (len-- > 0) {
4488                 fromstr = NEXTFROM;
4489                 auint = SvUV(fromstr);
4490                 SvGROW(cat, SvCUR(cat) + 10);
4491                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4492                                - SvPVX(cat));
4493             }
4494             *SvEND(cat) = '\0';
4495             break;
4496         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4497         case 'f':
4498         case 'F':
4499             while (len-- > 0) {
4500                 fromstr = NEXTFROM;
4501                 afloat = (float)SvNV(fromstr);
4502                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4503             }
4504             break;
4505         case 'd':
4506         case 'D':
4507             while (len-- > 0) {
4508                 fromstr = NEXTFROM;
4509                 adouble = (double)SvNV(fromstr);
4510                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4511             }
4512             break;
4513         case 'n':
4514             while (len-- > 0) {
4515                 fromstr = NEXTFROM;
4516                 ashort = (I16)SvIV(fromstr);
4517 #ifdef HAS_HTONS
4518                 ashort = PerlSock_htons(ashort);
4519 #endif
4520                 CAT16(cat, &ashort);
4521             }
4522             break;
4523         case 'v':
4524             while (len-- > 0) {
4525                 fromstr = NEXTFROM;
4526                 ashort = (I16)SvIV(fromstr);
4527 #ifdef HAS_HTOVS
4528                 ashort = htovs(ashort);
4529 #endif
4530                 CAT16(cat, &ashort);
4531             }
4532             break;
4533         case 'S':
4534 #if SHORTSIZE != SIZE16
4535             if (natint) {
4536                 unsigned short aushort;
4537
4538                 while (len-- > 0) {
4539                     fromstr = NEXTFROM;
4540                     aushort = SvUV(fromstr);
4541                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4542                 }
4543             }
4544             else
4545 #endif
4546             {
4547                 U16 aushort;
4548
4549                 while (len-- > 0) {
4550                     fromstr = NEXTFROM;
4551                     aushort = (U16)SvUV(fromstr);
4552                     CAT16(cat, &aushort);
4553                 }
4554
4555             }
4556             break;
4557         case 's':
4558 #if SHORTSIZE != 2
4559             if (natint) {
4560                 while (len-- > 0) {
4561                     fromstr = NEXTFROM;
4562                     ashort = SvIV(fromstr);
4563                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4564                 }
4565             }
4566             else
4567 #endif
4568             {
4569                 while (len-- > 0) {
4570                     fromstr = NEXTFROM;
4571                     ashort = (I16)SvIV(fromstr);
4572                     CAT16(cat, &ashort);
4573                 }
4574             }
4575             break;
4576         case 'I':
4577             while (len-- > 0) {
4578                 fromstr = NEXTFROM;
4579                 auint = SvUV(fromstr);
4580                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4581             }
4582             break;
4583         case 'w':
4584             while (len-- > 0) {
4585                 fromstr = NEXTFROM;
4586                 adouble = floor(SvNV(fromstr));
4587
4588                 if (adouble < 0)
4589                     croak("Cannot compress negative numbers");
4590
4591                 if (
4592 #ifdef BW_BITS
4593                     adouble <= BW_MASK
4594 #else
4595 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4596                     adouble <= UV_MAX_cxux
4597 #else
4598                     adouble <= UV_MAX
4599 #endif
4600 #endif
4601                     )
4602                 {
4603                     char   buf[1 + sizeof(UV)];
4604                     char  *in = buf + sizeof(buf);
4605                     UV     auv = U_V(adouble);;
4606
4607                     do {
4608                         *--in = (auv & 0x7f) | 0x80;
4609                         auv >>= 7;
4610                     } while (auv);
4611                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4612                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4613                 }
4614                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4615                     char           *from, *result, *in;
4616                     SV             *norm;
4617                     STRLEN          len;
4618                     bool            done;
4619
4620                     /* Copy string and check for compliance */
4621                     from = SvPV(fromstr, len);
4622                     if ((norm = is_an_int(from, len)) == NULL)
4623                         croak("can compress only unsigned integer");
4624
4625                     New('w', result, len, char);
4626                     in = result + len;
4627                     done = FALSE;
4628                     while (!done)
4629                         *--in = div128(norm, &done) | 0x80;
4630                     result[len - 1] &= 0x7F; /* clear continue bit */
4631                     sv_catpvn(cat, in, (result + len) - in);
4632                     Safefree(result);
4633                     SvREFCNT_dec(norm); /* free norm */
4634                 }
4635                 else if (SvNOKp(fromstr)) {
4636                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4637                     char  *in = buf + sizeof(buf);
4638
4639                     do {
4640                         double next = floor(adouble / 128);
4641                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4642                         if (--in < buf)  /* this cannot happen ;-) */
4643                             croak ("Cannot compress integer");
4644                         adouble = next;
4645                     } while (adouble > 0);
4646                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4647                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4648                 }
4649                 else
4650                     croak("Cannot compress non integer");
4651             }
4652             break;
4653         case 'i':
4654             while (len-- > 0) {
4655                 fromstr = NEXTFROM;
4656                 aint = SvIV(fromstr);
4657                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4658             }
4659             break;
4660         case 'N':
4661             while (len-- > 0) {
4662                 fromstr = NEXTFROM;
4663                 aulong = SvUV(fromstr);
4664 #ifdef HAS_HTONL
4665                 aulong = PerlSock_htonl(aulong);
4666 #endif
4667                 CAT32(cat, &aulong);
4668             }
4669             break;
4670         case 'V':
4671             while (len-- > 0) {
4672                 fromstr = NEXTFROM;
4673                 aulong = SvUV(fromstr);
4674 #ifdef HAS_HTOVL
4675                 aulong = htovl(aulong);
4676 #endif
4677                 CAT32(cat, &aulong);
4678             }
4679             break;
4680         case 'L':
4681 #if LONGSIZE != SIZE32
4682             if (natint) {
4683                 while (len-- > 0) {
4684                     fromstr = NEXTFROM;
4685                     aulong = SvUV(fromstr);
4686                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4687                 }
4688             }
4689             else
4690 #endif
4691             {
4692                 while (len-- > 0) {
4693                     fromstr = NEXTFROM;
4694                     aulong = SvUV(fromstr);
4695                     CAT32(cat, &aulong);
4696                 }
4697             }
4698             break;
4699         case 'l':
4700 #if LONGSIZE != SIZE32
4701             if (natint) {
4702                 while (len-- > 0) {
4703                     fromstr = NEXTFROM;
4704                     along = SvIV(fromstr);
4705                     sv_catpvn(cat, (char *)&along, sizeof(long));
4706                 }
4707             }
4708             else
4709 #endif
4710             {
4711                 while (len-- > 0) {
4712                     fromstr = NEXTFROM;
4713                     along = SvIV(fromstr);
4714                     CAT32(cat, &along);
4715                 }
4716             }
4717             break;
4718 #ifdef HAS_QUAD
4719         case 'Q':
4720             while (len-- > 0) {
4721                 fromstr = NEXTFROM;
4722                 auquad = (Uquad_t)SvIV(fromstr);
4723                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4724             }
4725             break;
4726         case 'q':
4727             while (len-- > 0) {
4728                 fromstr = NEXTFROM;
4729                 aquad = (Quad_t)SvIV(fromstr);
4730                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4731             }
4732             break;
4733 #endif /* HAS_QUAD */
4734         case 'P':
4735             len = 1;            /* assume SV is correct length */
4736             /* FALL THROUGH */
4737         case 'p':
4738             while (len-- > 0) {
4739                 fromstr = NEXTFROM;
4740                 if (fromstr == &PL_sv_undef)
4741                     aptr = NULL;
4742                 else {
4743                     STRLEN n_a;
4744                     /* XXX better yet, could spirit away the string to
4745                      * a safe spot and hang on to it until the result
4746                      * of pack() (and all copies of the result) are
4747                      * gone.
4748                      */
4749                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4750                         warner(WARN_UNSAFE,
4751                                 "Attempt to pack pointer to temporary value");
4752                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4753                         aptr = SvPV(fromstr,n_a);
4754                     else
4755                         aptr = SvPV_force(fromstr,n_a);
4756                 }
4757                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4758             }
4759             break;
4760         case 'u':
4761             fromstr = NEXTFROM;
4762             aptr = SvPV(fromstr, fromlen);
4763             SvGROW(cat, fromlen * 4 / 3);
4764             if (len <= 1)
4765                 len = 45;
4766             else
4767                 len = len / 3 * 3;
4768             while (fromlen > 0) {
4769                 I32 todo;
4770
4771                 if (fromlen > len)
4772                     todo = len;
4773                 else
4774                     todo = fromlen;
4775                 doencodes(cat, aptr, todo);
4776                 fromlen -= todo;
4777                 aptr += todo;
4778             }
4779             break;
4780         }
4781     }
4782     SvSETMAGIC(cat);
4783     SP = ORIGMARK;
4784     PUSHs(cat);
4785     RETURN;
4786 }
4787 #undef NEXTFROM
4788
4789
4790 PP(pp_split)
4791 {
4792     djSP; dTARG;
4793     AV *ary;
4794     register I32 limit = POPi;                  /* note, negative is forever */
4795     SV *sv = POPs;
4796     STRLEN len;
4797     register char *s = SvPV(sv, len);
4798     char *strend = s + len;
4799     register PMOP *pm;
4800     register REGEXP *rx;
4801     register SV *dstr;
4802     register char *m;
4803     I32 iters = 0;
4804     I32 maxiters = (strend - s) + 10;
4805     I32 i;
4806     char *orig;
4807     I32 origlimit = limit;
4808     I32 realarray = 0;
4809     I32 base;
4810     AV *oldstack = PL_curstack;
4811     I32 gimme = GIMME_V;
4812     I32 oldsave = PL_savestack_ix;
4813     I32 make_mortal = 1;
4814     MAGIC *mg = (MAGIC *) NULL;
4815
4816 #ifdef DEBUGGING
4817     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4818 #else
4819     pm = (PMOP*)POPs;
4820 #endif
4821     if (!pm || !s)
4822         DIE("panic: do_split");
4823     rx = pm->op_pmregexp;
4824
4825     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4826              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4827
4828     if (pm->op_pmreplroot)
4829         ary = GvAVn((GV*)pm->op_pmreplroot);
4830     else if (gimme != G_ARRAY)
4831 #ifdef USE_THREADS
4832         ary = (AV*)PL_curpad[0];
4833 #else
4834         ary = GvAVn(PL_defgv);
4835 #endif /* USE_THREADS */
4836     else
4837         ary = Nullav;
4838     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4839         realarray = 1;
4840         PUTBACK;
4841         av_extend(ary,0);
4842         av_clear(ary);
4843         SPAGAIN;
4844         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4845             PUSHMARK(SP);
4846             XPUSHs(SvTIED_obj((SV*)ary, mg));
4847         }
4848         else {
4849             if (!AvREAL(ary)) {
4850                 AvREAL_on(ary);
4851                 for (i = AvFILLp(ary); i >= 0; i--)
4852                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4853             }
4854             /* temporarily switch stacks */
4855             SWITCHSTACK(PL_curstack, ary);
4856             make_mortal = 0;
4857         }
4858     }
4859     base = SP - PL_stack_base;
4860     orig = s;
4861     if (pm->op_pmflags & PMf_SKIPWHITE) {
4862         if (pm->op_pmflags & PMf_LOCALE) {
4863             while (isSPACE_LC(*s))
4864                 s++;
4865         }
4866         else {
4867             while (isSPACE(*s))
4868                 s++;
4869         }
4870     }
4871     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4872         SAVEINT(PL_multiline);
4873         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4874     }
4875
4876     if (!limit)
4877         limit = maxiters + 2;
4878     if (pm->op_pmflags & PMf_WHITE) {
4879         while (--limit) {
4880             m = s;
4881             while (m < strend &&
4882                    !((pm->op_pmflags & PMf_LOCALE)
4883                      ? isSPACE_LC(*m) : isSPACE(*m)))
4884                 ++m;
4885             if (m >= strend)
4886                 break;
4887
4888             dstr = NEWSV(30, m-s);
4889             sv_setpvn(dstr, s, m-s);
4890             if (make_mortal)
4891                 sv_2mortal(dstr);
4892             XPUSHs(dstr);
4893
4894             s = m + 1;
4895             while (s < strend &&
4896                    ((pm->op_pmflags & PMf_LOCALE)
4897                     ? isSPACE_LC(*s) : isSPACE(*s)))
4898                 ++s;
4899         }
4900     }
4901     else if (strEQ("^", rx->precomp)) {
4902         while (--limit) {
4903             /*SUPPRESS 530*/
4904             for (m = s; m < strend && *m != '\n'; m++) ;
4905             m++;
4906             if (m >= strend)
4907                 break;
4908             dstr = NEWSV(30, m-s);
4909             sv_setpvn(dstr, s, m-s);
4910             if (make_mortal)
4911                 sv_2mortal(dstr);
4912             XPUSHs(dstr);
4913             s = m;
4914         }
4915     }
4916     else if (rx->check_substr && !rx->nparens
4917              && (rx->reganch & ROPT_CHECK_ALL)
4918              && !(rx->reganch & ROPT_ANCH)) {
4919         i = SvCUR(rx->check_substr);
4920         if (i == 1 && !SvTAIL(rx->check_substr)) {
4921             i = *SvPVX(rx->check_substr);
4922             while (--limit) {
4923                 /*SUPPRESS 530*/
4924                 for (m = s; m < strend && *m != i; m++) ;
4925                 if (m >= strend)
4926                     break;
4927                 dstr = NEWSV(30, m-s);
4928                 sv_setpvn(dstr, s, m-s);
4929                 if (make_mortal)
4930                     sv_2mortal(dstr);
4931                 XPUSHs(dstr);
4932                 s = m + 1;
4933             }
4934         }
4935         else {
4936 #ifndef lint
4937             while (s < strend && --limit &&
4938               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4939                     rx->check_substr, 0)) )
4940 #endif
4941             {
4942                 dstr = NEWSV(31, m-s);
4943                 sv_setpvn(dstr, s, m-s);
4944                 if (make_mortal)
4945                     sv_2mortal(dstr);
4946                 XPUSHs(dstr);
4947                 s = m + i;
4948             }
4949         }
4950     }
4951     else {
4952         maxiters += (strend - s) * rx->nparens;
4953         while (s < strend && --limit &&
4954                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4955         {
4956             TAINT_IF(RX_MATCH_TAINTED(rx));
4957             if (rx->subbase
4958               && rx->subbase != orig) {
4959                 m = s;
4960                 s = orig;
4961                 orig = rx->subbase;
4962                 s = orig + (m - s);
4963                 strend = s + (strend - m);
4964             }
4965             m = rx->startp[0];
4966             dstr = NEWSV(32, m-s);
4967             sv_setpvn(dstr, s, m-s);
4968             if (make_mortal)
4969                 sv_2mortal(dstr);
4970             XPUSHs(dstr);
4971             if (rx->nparens) {
4972                 for (i = 1; i <= rx->nparens; i++) {
4973                     s = rx->startp[i];
4974                     m = rx->endp[i];
4975                     if (m && s) {
4976                         dstr = NEWSV(33, m-s);
4977                         sv_setpvn(dstr, s, m-s);
4978                     }
4979                     else
4980                         dstr = NEWSV(33, 0);
4981                     if (make_mortal)
4982                         sv_2mortal(dstr);
4983                     XPUSHs(dstr);
4984                 }
4985             }
4986             s = rx->endp[0];
4987         }
4988     }
4989
4990     LEAVE_SCOPE(oldsave);
4991     iters = (SP - PL_stack_base) - base;
4992     if (iters > maxiters)
4993         DIE("Split loop");
4994
4995     /* keep field after final delim? */
4996     if (s < strend || (iters && origlimit)) {
4997         dstr = NEWSV(34, strend-s);
4998         sv_setpvn(dstr, s, strend-s);
4999         if (make_mortal)
5000             sv_2mortal(dstr);
5001         XPUSHs(dstr);
5002         iters++;
5003     }
5004     else if (!origlimit) {
5005         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5006             iters--, SP--;
5007     }
5008
5009     if (realarray) {
5010         if (!mg) {
5011             SWITCHSTACK(ary, oldstack);
5012             if (SvSMAGICAL(ary)) {
5013                 PUTBACK;
5014                 mg_set((SV*)ary);
5015                 SPAGAIN;
5016             }
5017             if (gimme == G_ARRAY) {
5018                 EXTEND(SP, iters);
5019                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5020                 SP += iters;
5021                 RETURN;
5022             }
5023         }
5024         else {
5025             PUTBACK;
5026             ENTER;
5027             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5028             LEAVE;
5029             SPAGAIN;
5030             if (gimme == G_ARRAY) {
5031                 /* EXTEND should not be needed - we just popped them */
5032                 EXTEND(SP, iters);
5033                 for (i=0; i < iters; i++) {
5034                     SV **svp = av_fetch(ary, i, FALSE);
5035                     PUSHs((svp) ? *svp : &PL_sv_undef);
5036                 }
5037                 RETURN;
5038             }
5039         }
5040     }
5041     else {
5042         if (gimme == G_ARRAY)
5043             RETURN;
5044     }
5045     if (iters || !pm->op_pmreplroot) {
5046         GETTARGET;
5047         PUSHi(iters);
5048         RETURN;
5049     }
5050     RETPUSHUNDEF;
5051 }
5052
5053 #ifdef USE_THREADS
5054 void
5055 unlock_condpair(void *svv)
5056 {
5057     dTHR;
5058     MAGIC *mg = mg_find((SV*)svv, 'm');
5059
5060     if (!mg)
5061         croak("panic: unlock_condpair unlocking non-mutex");
5062     MUTEX_LOCK(MgMUTEXP(mg));
5063     if (MgOWNER(mg) != thr)
5064         croak("panic: unlock_condpair unlocking mutex that we don't own");
5065     MgOWNER(mg) = 0;
5066     COND_SIGNAL(MgOWNERCONDP(mg));
5067     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5068                           (unsigned long)thr, (unsigned long)svv);)
5069     MUTEX_UNLOCK(MgMUTEXP(mg));
5070 }
5071 #endif /* USE_THREADS */
5072
5073 PP(pp_lock)
5074 {
5075     djSP;
5076     dTOPss;
5077     SV *retsv = sv;
5078 #ifdef USE_THREADS
5079     MAGIC *mg;
5080
5081     if (SvROK(sv))
5082         sv = SvRV(sv);
5083
5084     mg = condpair_magic(sv);
5085     MUTEX_LOCK(MgMUTEXP(mg));
5086     if (MgOWNER(mg) == thr)
5087         MUTEX_UNLOCK(MgMUTEXP(mg));
5088     else {
5089         while (MgOWNER(mg))
5090             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5091         MgOWNER(mg) = thr;
5092         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5093                               (unsigned long)thr, (unsigned long)sv);)
5094         MUTEX_UNLOCK(MgMUTEXP(mg));
5095         save_destructor(unlock_condpair, sv);
5096     }
5097 #endif /* USE_THREADS */
5098     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5099         || SvTYPE(retsv) == SVt_PVCV) {
5100         retsv = refto(retsv);
5101     }
5102     SETs(retsv);
5103     RETURN;
5104 }
5105
5106 PP(pp_threadsv)
5107 {
5108     djSP;
5109 #ifdef USE_THREADS
5110     EXTEND(SP, 1);
5111     if (PL_op->op_private & OPpLVAL_INTRO)
5112         PUSHs(*save_threadsv(PL_op->op_targ));
5113     else
5114         PUSHs(THREADSV(PL_op->op_targ));
5115     RETURN;
5116 #else
5117     DIE("tried to access per-thread data in non-threaded perl");
5118 #endif /* USE_THREADS */
5119 }