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 #if SHORTSIZE > SIZE16
3553                         if (ashort > 32767)
3554                           ashort -= 65536;
3555 #endif
3556                         s += SIZE16;
3557                         culong += ashort;
3558                     }
3559                 }
3560             }
3561             else {
3562                 EXTEND(SP, len);
3563                 EXTEND_MORTAL(len);
3564 #if SHORTSIZE != SIZE16
3565                 if (natint) {
3566                     while (len-- > 0) {
3567                         COPYNN(s, &ashort, sizeof(short));
3568                         s += sizeof(short);
3569                         sv = NEWSV(38, 0);
3570                         sv_setiv(sv, (IV)ashort);
3571                         PUSHs(sv_2mortal(sv));
3572                     }
3573                 }
3574                 else
3575 #endif
3576                 {
3577                     while (len-- > 0) {
3578                         COPY16(s, &ashort);
3579 #if SHORTSIZE > SIZE16
3580                         if (ashort > 32767)
3581                           ashort -= 65536;
3582 #endif
3583                         s += SIZE16;
3584                         sv = NEWSV(38, 0);
3585                         sv_setiv(sv, (IV)ashort);
3586                         PUSHs(sv_2mortal(sv));
3587                     }
3588                 }
3589             }
3590             break;
3591         case 'v':
3592         case 'n':
3593         case 'S':
3594 #if SHORTSIZE == SIZE16
3595             along = (strend - s) / SIZE16;
3596 #else
3597             unatint = natint && datumtype == 'S';
3598             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3599 #endif
3600             if (len > along)
3601                 len = along;
3602             if (checksum) {
3603 #if SHORTSIZE != SIZE16
3604                 if (unatint) {
3605                     while (len-- > 0) {
3606                         COPYNN(s, &aushort, sizeof(unsigned short));
3607                         s += sizeof(unsigned short);
3608                         culong += aushort;
3609                     }
3610                 }
3611                 else
3612 #endif
3613                 {
3614                     while (len-- > 0) {
3615                         COPY16(s, &aushort);
3616                         s += SIZE16;
3617 #ifdef HAS_NTOHS
3618                         if (datumtype == 'n')
3619                             aushort = PerlSock_ntohs(aushort);
3620 #endif
3621 #ifdef HAS_VTOHS
3622                         if (datumtype == 'v')
3623                             aushort = vtohs(aushort);
3624 #endif
3625                         culong += aushort;
3626                     }
3627                 }
3628             }
3629             else {
3630                 EXTEND(SP, len);
3631                 EXTEND_MORTAL(len);
3632 #if SHORTSIZE != SIZE16
3633                 if (unatint) {
3634                     while (len-- > 0) {
3635                         COPYNN(s, &aushort, sizeof(unsigned short));
3636                         s += sizeof(unsigned short);
3637                         sv = NEWSV(39, 0);
3638                         sv_setiv(sv, (UV)aushort);
3639                         PUSHs(sv_2mortal(sv));
3640                     }
3641                 }
3642                 else
3643 #endif
3644                 {
3645                     while (len-- > 0) {
3646                         COPY16(s, &aushort);
3647                         s += SIZE16;
3648                         sv = NEWSV(39, 0);
3649 #ifdef HAS_NTOHS
3650                         if (datumtype == 'n')
3651                             aushort = PerlSock_ntohs(aushort);
3652 #endif
3653 #ifdef HAS_VTOHS
3654                         if (datumtype == 'v')
3655                             aushort = vtohs(aushort);
3656 #endif
3657                         sv_setiv(sv, (UV)aushort);
3658                         PUSHs(sv_2mortal(sv));
3659                     }
3660                 }
3661             }
3662             break;
3663         case 'i':
3664             along = (strend - s) / sizeof(int);
3665             if (len > along)
3666                 len = along;
3667             if (checksum) {
3668                 while (len-- > 0) {
3669                     Copy(s, &aint, 1, int);
3670                     s += sizeof(int);
3671                     if (checksum > 32)
3672                         cdouble += (double)aint;
3673                     else
3674                         culong += aint;
3675                 }
3676             }
3677             else {
3678                 EXTEND(SP, len);
3679                 EXTEND_MORTAL(len);
3680                 while (len-- > 0) {
3681                     Copy(s, &aint, 1, int);
3682                     s += sizeof(int);
3683                     sv = NEWSV(40, 0);
3684 #ifdef __osf__
3685                     /* Without the dummy below unpack("i", pack("i",-1))
3686                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3687                      * cc with optimization turned on */
3688                     (aint) ?
3689                         sv_setiv(sv, (IV)aint) :
3690 #endif
3691                     sv_setiv(sv, (IV)aint);
3692                     PUSHs(sv_2mortal(sv));
3693                 }
3694             }
3695             break;
3696         case 'I':
3697             along = (strend - s) / sizeof(unsigned int);
3698             if (len > along)
3699                 len = along;
3700             if (checksum) {
3701                 while (len-- > 0) {
3702                     Copy(s, &auint, 1, unsigned int);
3703                     s += sizeof(unsigned int);
3704                     if (checksum > 32)
3705                         cdouble += (double)auint;
3706                     else
3707                         culong += auint;
3708                 }
3709             }
3710             else {
3711                 EXTEND(SP, len);
3712                 EXTEND_MORTAL(len);
3713                 while (len-- > 0) {
3714                     Copy(s, &auint, 1, unsigned int);
3715                     s += sizeof(unsigned int);
3716                     sv = NEWSV(41, 0);
3717 #ifdef __osf__
3718                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3719                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3720                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3721                      * with optimization turned on.
3722                      * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3723                      * does not have this problem even with -O4)
3724                      */
3725                     (auint) ?
3726                         sv_setuv(sv, (UV)auint) :
3727 #endif
3728                     sv_setuv(sv, (UV)auint);
3729                     PUSHs(sv_2mortal(sv));
3730                 }
3731             }
3732             break;
3733         case 'l':
3734 #if LONGSIZE == SIZE32
3735             along = (strend - s) / SIZE32;
3736 #else
3737             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3738 #endif
3739             if (len > along)
3740                 len = along;
3741             if (checksum) {
3742 #if LONGSIZE != SIZE32
3743                 if (natint) {
3744                     while (len-- > 0) {
3745                         COPYNN(s, &along, sizeof(long));
3746                         s += sizeof(long);
3747                         if (checksum > 32)
3748                             cdouble += (double)along;
3749                         else
3750                             culong += along;
3751                     }
3752                 }
3753                 else
3754 #endif
3755                 {
3756                     while (len-- > 0) {
3757                         COPY32(s, &along);
3758 #if LONGSIZE > SIZE32
3759                         if (along > 2147483647)
3760                           along -= 4294967296;
3761 #endif
3762                         s += SIZE32;
3763                         if (checksum > 32)
3764                             cdouble += (double)along;
3765                         else
3766                             culong += along;
3767                     }
3768                 }
3769             }
3770             else {
3771                 EXTEND(SP, len);
3772                 EXTEND_MORTAL(len);
3773 #if LONGSIZE != SIZE32
3774                 if (natint) {
3775                     while (len-- > 0) {
3776                         COPYNN(s, &along, sizeof(long));
3777                         s += sizeof(long);
3778                         sv = NEWSV(42, 0);
3779                         sv_setiv(sv, (IV)along);
3780                         PUSHs(sv_2mortal(sv));
3781                     }
3782                 }
3783                 else
3784 #endif
3785                 {
3786                     while (len-- > 0) {
3787                         COPY32(s, &along);
3788 #if LONGSIZE > SIZE32
3789                         if (along > 2147483647)
3790                           along -= 4294967296;
3791 #endif
3792                         s += SIZE32;
3793                         sv = NEWSV(42, 0);
3794                         sv_setiv(sv, (IV)along);
3795                         PUSHs(sv_2mortal(sv));
3796                     }
3797                 }
3798             }
3799             break;
3800         case 'V':
3801         case 'N':
3802         case 'L':
3803 #if LONGSIZE == SIZE32
3804             along = (strend - s) / SIZE32;
3805 #else
3806             unatint = natint && datumtype == 'L';
3807             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3808 #endif
3809             if (len > along)
3810                 len = along;
3811             if (checksum) {
3812 #if LONGSIZE != SIZE32
3813                 if (unatint) {
3814                     while (len-- > 0) {
3815                         COPYNN(s, &aulong, sizeof(unsigned long));
3816                         s += sizeof(unsigned long);
3817                         if (checksum > 32)
3818                             cdouble += (double)aulong;
3819                         else
3820                             culong += aulong;
3821                     }
3822                 }
3823                 else
3824 #endif
3825                 {
3826                     while (len-- > 0) {
3827                         COPY32(s, &aulong);
3828                         s += SIZE32;
3829 #ifdef HAS_NTOHL
3830                         if (datumtype == 'N')
3831                             aulong = PerlSock_ntohl(aulong);
3832 #endif
3833 #ifdef HAS_VTOHL
3834                         if (datumtype == 'V')
3835                             aulong = vtohl(aulong);
3836 #endif
3837                         if (checksum > 32)
3838                             cdouble += (double)aulong;
3839                         else
3840                             culong += aulong;
3841                     }
3842                 }
3843             }
3844             else {
3845                 EXTEND(SP, len);
3846                 EXTEND_MORTAL(len);
3847 #if LONGSIZE != SIZE32
3848                 if (unatint) {
3849                     while (len-- > 0) {
3850                         COPYNN(s, &aulong, sizeof(unsigned long));
3851                         s += sizeof(unsigned long);
3852                         sv = NEWSV(43, 0);
3853                         sv_setuv(sv, (UV)aulong);
3854                         PUSHs(sv_2mortal(sv));
3855                     }
3856                 }
3857                 else
3858 #endif
3859                 {
3860                     while (len-- > 0) {
3861                         COPY32(s, &aulong);
3862                         s += SIZE32;
3863 #ifdef HAS_NTOHL
3864                         if (datumtype == 'N')
3865                             aulong = PerlSock_ntohl(aulong);
3866 #endif
3867 #ifdef HAS_VTOHL
3868                         if (datumtype == 'V')
3869                             aulong = vtohl(aulong);
3870 #endif
3871                         sv = NEWSV(43, 0);
3872                         sv_setuv(sv, (UV)aulong);
3873                         PUSHs(sv_2mortal(sv));
3874                     }
3875                 }
3876             }
3877             break;
3878         case 'p':
3879             along = (strend - s) / sizeof(char*);
3880             if (len > along)
3881                 len = along;
3882             EXTEND(SP, len);
3883             EXTEND_MORTAL(len);
3884             while (len-- > 0) {
3885                 if (sizeof(char*) > strend - s)
3886                     break;
3887                 else {
3888                     Copy(s, &aptr, 1, char*);
3889                     s += sizeof(char*);
3890                 }
3891                 sv = NEWSV(44, 0);
3892                 if (aptr)
3893                     sv_setpv(sv, aptr);
3894                 PUSHs(sv_2mortal(sv));
3895             }
3896             break;
3897         case 'w':
3898             EXTEND(SP, len);
3899             EXTEND_MORTAL(len);
3900             {
3901                 UV auv = 0;
3902                 U32 bytes = 0;
3903
3904                 while ((len > 0) && (s < strend)) {
3905                     auv = (auv << 7) | (*s & 0x7f);
3906                     if (!(*s++ & 0x80)) {
3907                         bytes = 0;
3908                         sv = NEWSV(40, 0);
3909                         sv_setuv(sv, auv);
3910                         PUSHs(sv_2mortal(sv));
3911                         len--;
3912                         auv = 0;
3913                     }
3914                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3915                         char *t;
3916                         STRLEN n_a;
3917
3918                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3919                         while (s < strend) {
3920                             sv = mul128(sv, *s & 0x7f);
3921                             if (!(*s++ & 0x80)) {
3922                                 bytes = 0;
3923                                 break;
3924                             }
3925                         }
3926                         t = SvPV(sv, n_a);
3927                         while (*t == '0')
3928                             t++;
3929                         sv_chop(sv, t);
3930                         PUSHs(sv_2mortal(sv));
3931                         len--;
3932                         auv = 0;
3933                     }
3934                 }
3935                 if ((s >= strend) && bytes)
3936                     croak("Unterminated compressed integer");
3937             }
3938             break;
3939         case 'P':
3940             EXTEND(SP, 1);
3941             if (sizeof(char*) > strend - s)
3942                 break;
3943             else {
3944                 Copy(s, &aptr, 1, char*);
3945                 s += sizeof(char*);
3946             }
3947             sv = NEWSV(44, 0);
3948             if (aptr)
3949                 sv_setpvn(sv, aptr, len);
3950             PUSHs(sv_2mortal(sv));
3951             break;
3952 #ifdef HAS_QUAD
3953         case 'q':
3954             along = (strend - s) / sizeof(Quad_t);
3955             if (len > along)
3956                 len = along;
3957             EXTEND(SP, len);
3958             EXTEND_MORTAL(len);
3959             while (len-- > 0) {
3960                 if (s + sizeof(Quad_t) > strend)
3961                     aquad = 0;
3962                 else {
3963                     Copy(s, &aquad, 1, Quad_t);
3964                     s += sizeof(Quad_t);
3965                 }
3966                 sv = NEWSV(42, 0);
3967                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3968                     sv_setiv(sv, (IV)aquad);
3969                 else
3970                     sv_setnv(sv, (double)aquad);
3971                 PUSHs(sv_2mortal(sv));
3972             }
3973             break;
3974         case 'Q':
3975             along = (strend - s) / sizeof(Quad_t);
3976             if (len > along)
3977                 len = along;
3978             EXTEND(SP, len);
3979             EXTEND_MORTAL(len);
3980             while (len-- > 0) {
3981                 if (s + sizeof(Uquad_t) > strend)
3982                     auquad = 0;
3983                 else {
3984                     Copy(s, &auquad, 1, Uquad_t);
3985                     s += sizeof(Uquad_t);
3986                 }
3987                 sv = NEWSV(43, 0);
3988                 if (auquad <= UV_MAX)
3989                     sv_setuv(sv, (UV)auquad);
3990                 else
3991                     sv_setnv(sv, (double)auquad);
3992                 PUSHs(sv_2mortal(sv));
3993             }
3994             break;
3995 #endif
3996         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3997         case 'f':
3998         case 'F':
3999             along = (strend - s) / sizeof(float);
4000             if (len > along)
4001                 len = along;
4002             if (checksum) {
4003                 while (len-- > 0) {
4004                     Copy(s, &afloat, 1, float);
4005                     s += sizeof(float);
4006                     cdouble += afloat;
4007                 }
4008             }
4009             else {
4010                 EXTEND(SP, len);
4011                 EXTEND_MORTAL(len);
4012                 while (len-- > 0) {
4013                     Copy(s, &afloat, 1, float);
4014                     s += sizeof(float);
4015                     sv = NEWSV(47, 0);
4016                     sv_setnv(sv, (double)afloat);
4017                     PUSHs(sv_2mortal(sv));
4018                 }
4019             }
4020             break;
4021         case 'd':
4022         case 'D':
4023             along = (strend - s) / sizeof(double);
4024             if (len > along)
4025                 len = along;
4026             if (checksum) {
4027                 while (len-- > 0) {
4028                     Copy(s, &adouble, 1, double);
4029                     s += sizeof(double);
4030                     cdouble += adouble;
4031                 }
4032             }
4033             else {
4034                 EXTEND(SP, len);
4035                 EXTEND_MORTAL(len);
4036                 while (len-- > 0) {
4037                     Copy(s, &adouble, 1, double);
4038                     s += sizeof(double);
4039                     sv = NEWSV(48, 0);
4040                     sv_setnv(sv, (double)adouble);
4041                     PUSHs(sv_2mortal(sv));
4042                 }
4043             }
4044             break;
4045         case 'u':
4046             /* MKS:
4047              * Initialise the decode mapping.  By using a table driven
4048              * algorithm, the code will be character-set independent
4049              * (and just as fast as doing character arithmetic)
4050              */
4051             if (PL_uudmap['M'] == 0) {
4052                 int i;
4053
4054                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4055                     PL_uudmap[PL_uuemap[i]] = i;
4056                 /*
4057                  * Because ' ' and '`' map to the same value,
4058                  * we need to decode them both the same.
4059                  */
4060                 PL_uudmap[' '] = 0;
4061             }
4062
4063             along = (strend - s) * 3 / 4;
4064             sv = NEWSV(42, along);
4065             if (along)
4066                 SvPOK_on(sv);
4067             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4068                 I32 a, b, c, d;
4069                 char hunk[4];
4070
4071                 hunk[3] = '\0';
4072                 len = PL_uudmap[*s++] & 077;
4073                 while (len > 0) {
4074                     if (s < strend && ISUUCHAR(*s))
4075                         a = PL_uudmap[*s++] & 077;
4076                     else
4077                         a = 0;
4078                     if (s < strend && ISUUCHAR(*s))
4079                         b = PL_uudmap[*s++] & 077;
4080                     else
4081                         b = 0;
4082                     if (s < strend && ISUUCHAR(*s))
4083                         c = PL_uudmap[*s++] & 077;
4084                     else
4085                         c = 0;
4086                     if (s < strend && ISUUCHAR(*s))
4087                         d = PL_uudmap[*s++] & 077;
4088                     else
4089                         d = 0;
4090                     hunk[0] = (a << 2) | (b >> 4);
4091                     hunk[1] = (b << 4) | (c >> 2);
4092                     hunk[2] = (c << 6) | d;
4093                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4094                     len -= 3;
4095                 }
4096                 if (*s == '\n')
4097                     s++;
4098                 else if (s[1] == '\n')          /* possible checksum byte */
4099                     s += 2;
4100             }
4101             XPUSHs(sv_2mortal(sv));
4102             break;
4103         }
4104         if (checksum) {
4105             sv = NEWSV(42, 0);
4106             if (strchr("fFdD", datumtype) ||
4107               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4108                 double trouble;
4109
4110                 adouble = 1.0;
4111                 while (checksum >= 16) {
4112                     checksum -= 16;
4113                     adouble *= 65536.0;
4114                 }
4115                 while (checksum >= 4) {
4116                     checksum -= 4;
4117                     adouble *= 16.0;
4118                 }
4119                 while (checksum--)
4120                     adouble *= 2.0;
4121                 along = (1 << checksum) - 1;
4122                 while (cdouble < 0.0)
4123                     cdouble += adouble;
4124                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4125                 sv_setnv(sv, cdouble);
4126             }
4127             else {
4128                 if (checksum < 32) {
4129                     aulong = (1 << checksum) - 1;
4130                     culong &= aulong;
4131                 }
4132                 sv_setuv(sv, (UV)culong);
4133             }
4134             XPUSHs(sv_2mortal(sv));
4135             checksum = 0;
4136         }
4137     }
4138     if (SP == oldsp && gimme == G_SCALAR)
4139         PUSHs(&PL_sv_undef);
4140     RETURN;
4141 }
4142
4143 STATIC void
4144 doencodes(register SV *sv, register char *s, register I32 len)
4145 {
4146     char hunk[5];
4147
4148     *hunk = PL_uuemap[len];
4149     sv_catpvn(sv, hunk, 1);
4150     hunk[4] = '\0';
4151     while (len > 2) {
4152         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4153         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4154         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4155         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4156         sv_catpvn(sv, hunk, 4);
4157         s += 3;
4158         len -= 3;
4159     }
4160     if (len > 0) {
4161         char r = (len > 1 ? s[1] : '\0');
4162         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4163         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4164         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4165         hunk[3] = PL_uuemap[0];
4166         sv_catpvn(sv, hunk, 4);
4167     }
4168     sv_catpvn(sv, "\n", 1);
4169 }
4170
4171 STATIC SV      *
4172 is_an_int(char *s, STRLEN l)
4173 {
4174   STRLEN         n_a;
4175   SV             *result = newSVpv("", l);
4176   char           *result_c = SvPV(result, n_a); /* convenience */
4177   char           *out = result_c;
4178   bool            skip = 1;
4179   bool            ignore = 0;
4180
4181   while (*s) {
4182     switch (*s) {
4183     case ' ':
4184       break;
4185     case '+':
4186       if (!skip) {
4187         SvREFCNT_dec(result);
4188         return (NULL);
4189       }
4190       break;
4191     case '0':
4192     case '1':
4193     case '2':
4194     case '3':
4195     case '4':
4196     case '5':
4197     case '6':
4198     case '7':
4199     case '8':
4200     case '9':
4201       skip = 0;
4202       if (!ignore) {
4203         *(out++) = *s;
4204       }
4205       break;
4206     case '.':
4207       ignore = 1;
4208       break;
4209     default:
4210       SvREFCNT_dec(result);
4211       return (NULL);
4212     }
4213     s++;
4214   }
4215   *(out++) = '\0';
4216   SvCUR_set(result, out - result_c);
4217   return (result);
4218 }
4219
4220 STATIC int
4221 div128(SV *pnum, bool *done)
4222                                             /* must be '\0' terminated */
4223
4224 {
4225   STRLEN          len;
4226   char           *s = SvPV(pnum, len);
4227   int             m = 0;
4228   int             r = 0;
4229   char           *t = s;
4230
4231   *done = 1;
4232   while (*t) {
4233     int             i;
4234
4235     i = m * 10 + (*t - '0');
4236     m = i & 0x7F;
4237     r = (i >> 7);               /* r < 10 */
4238     if (r) {
4239       *done = 0;
4240     }
4241     *(t++) = '0' + r;
4242   }
4243   *(t++) = '\0';
4244   SvCUR_set(pnum, (STRLEN) (t - s));
4245   return (m);
4246 }
4247
4248
4249 PP(pp_pack)
4250 {
4251     djSP; dMARK; dORIGMARK; dTARGET;
4252     register SV *cat = TARG;
4253     register I32 items;
4254     STRLEN fromlen;
4255     register char *pat = SvPVx(*++MARK, fromlen);
4256     register char *patend = pat + fromlen;
4257     register I32 len;
4258     I32 datumtype;
4259     SV *fromstr;
4260     /*SUPPRESS 442*/
4261     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4262     static char *space10 = "          ";
4263
4264     /* These must not be in registers: */
4265     char achar;
4266     I16 ashort;
4267     int aint;
4268     unsigned int auint;
4269     I32 along;
4270     U32 aulong;
4271 #ifdef HAS_QUAD
4272     Quad_t aquad;
4273     Uquad_t auquad;
4274 #endif
4275     char *aptr;
4276     float afloat;
4277     double adouble;
4278     int commas = 0;
4279 #ifdef PERL_NATINT_PACK
4280     int natint;         /* native integer */
4281 #endif
4282
4283     items = SP - MARK;
4284     MARK++;
4285     sv_setpvn(cat, "", 0);
4286     while (pat < patend) {
4287 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4288         datumtype = *pat++ & 0xFF;
4289 #ifdef PERL_NATINT_PACK
4290         natint = 0;
4291 #endif
4292         if (isSPACE(datumtype))
4293             continue;
4294         if (*pat == '_') {
4295             char *natstr = "sSiIlL";
4296
4297             if (strchr(natstr, datumtype)) {
4298 #ifdef PERL_NATINT_PACK
4299                 natint = 1;
4300 #endif
4301                 pat++;
4302             }
4303             else
4304                 croak("'_' allowed only after types %s", natstr);
4305         }
4306         if (*pat == '*') {
4307             len = strchr("@Xxu", datumtype) ? 0 : items;
4308             pat++;
4309         }
4310         else if (isDIGIT(*pat)) {
4311             len = *pat++ - '0';
4312             while (isDIGIT(*pat))
4313                 len = (len * 10) + (*pat++ - '0');
4314         }
4315         else
4316             len = 1;
4317         switch(datumtype) {
4318         default:
4319             croak("Invalid type in pack: '%c'", (int)datumtype);
4320         case ',': /* grandfather in commas but with a warning */
4321             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4322                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4323             break;
4324         case '%':
4325             DIE("%% may only be used in unpack");
4326         case '@':
4327             len -= SvCUR(cat);
4328             if (len > 0)
4329                 goto grow;
4330             len = -len;
4331             if (len > 0)
4332                 goto shrink;
4333             break;
4334         case 'X':
4335           shrink:
4336             if (SvCUR(cat) < len)
4337                 DIE("X outside of string");
4338             SvCUR(cat) -= len;
4339             *SvEND(cat) = '\0';
4340             break;
4341         case 'x':
4342           grow:
4343             while (len >= 10) {
4344                 sv_catpvn(cat, null10, 10);
4345                 len -= 10;
4346             }
4347             sv_catpvn(cat, null10, len);
4348             break;
4349         case 'A':
4350         case 'Z':
4351         case 'a':
4352             fromstr = NEXTFROM;
4353             aptr = SvPV(fromstr, fromlen);
4354             if (pat[-1] == '*')
4355                 len = fromlen;
4356             if (fromlen > len)
4357                 sv_catpvn(cat, aptr, len);
4358             else {
4359                 sv_catpvn(cat, aptr, fromlen);
4360                 len -= fromlen;
4361                 if (datumtype == 'A') {
4362                     while (len >= 10) {
4363                         sv_catpvn(cat, space10, 10);
4364                         len -= 10;
4365                     }
4366                     sv_catpvn(cat, space10, len);
4367                 }
4368                 else {
4369                     while (len >= 10) {
4370                         sv_catpvn(cat, null10, 10);
4371                         len -= 10;
4372                     }
4373                     sv_catpvn(cat, null10, len);
4374                 }
4375             }
4376             break;
4377         case 'B':
4378         case 'b':
4379             {
4380                 char *savepat = pat;
4381                 I32 saveitems;
4382
4383                 fromstr = NEXTFROM;
4384                 saveitems = items;
4385                 aptr = SvPV(fromstr, fromlen);
4386                 if (pat[-1] == '*')
4387                     len = fromlen;
4388                 pat = aptr;
4389                 aint = SvCUR(cat);
4390                 SvCUR(cat) += (len+7)/8;
4391                 SvGROW(cat, SvCUR(cat) + 1);
4392                 aptr = SvPVX(cat) + aint;
4393                 if (len > fromlen)
4394                     len = fromlen;
4395                 aint = len;
4396                 items = 0;
4397                 if (datumtype == 'B') {
4398                     for (len = 0; len++ < aint;) {
4399                         items |= *pat++ & 1;
4400                         if (len & 7)
4401                             items <<= 1;
4402                         else {
4403                             *aptr++ = items & 0xff;
4404                             items = 0;
4405                         }
4406                     }
4407                 }
4408                 else {
4409                     for (len = 0; len++ < aint;) {
4410                         if (*pat++ & 1)
4411                             items |= 128;
4412                         if (len & 7)
4413                             items >>= 1;
4414                         else {
4415                             *aptr++ = items & 0xff;
4416                             items = 0;
4417                         }
4418                     }
4419                 }
4420                 if (aint & 7) {
4421                     if (datumtype == 'B')
4422                         items <<= 7 - (aint & 7);
4423                     else
4424                         items >>= 7 - (aint & 7);
4425                     *aptr++ = items & 0xff;
4426                 }
4427                 pat = SvPVX(cat) + SvCUR(cat);
4428                 while (aptr <= pat)
4429                     *aptr++ = '\0';
4430
4431                 pat = savepat;
4432                 items = saveitems;
4433             }
4434             break;
4435         case 'H':
4436         case 'h':
4437             {
4438                 char *savepat = pat;
4439                 I32 saveitems;
4440
4441                 fromstr = NEXTFROM;
4442                 saveitems = items;
4443                 aptr = SvPV(fromstr, fromlen);
4444                 if (pat[-1] == '*')
4445                     len = fromlen;
4446                 pat = aptr;
4447                 aint = SvCUR(cat);
4448                 SvCUR(cat) += (len+1)/2;
4449                 SvGROW(cat, SvCUR(cat) + 1);
4450                 aptr = SvPVX(cat) + aint;
4451                 if (len > fromlen)
4452                     len = fromlen;
4453                 aint = len;
4454                 items = 0;
4455                 if (datumtype == 'H') {
4456                     for (len = 0; len++ < aint;) {
4457                         if (isALPHA(*pat))
4458                             items |= ((*pat++ & 15) + 9) & 15;
4459                         else
4460                             items |= *pat++ & 15;
4461                         if (len & 1)
4462                             items <<= 4;
4463                         else {
4464                             *aptr++ = items & 0xff;
4465                             items = 0;
4466                         }
4467                     }
4468                 }
4469                 else {
4470                     for (len = 0; len++ < aint;) {
4471                         if (isALPHA(*pat))
4472                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4473                         else
4474                             items |= (*pat++ & 15) << 4;
4475                         if (len & 1)
4476                             items >>= 4;
4477                         else {
4478                             *aptr++ = items & 0xff;
4479                             items = 0;
4480                         }
4481                     }
4482                 }
4483                 if (aint & 1)
4484                     *aptr++ = items & 0xff;
4485                 pat = SvPVX(cat) + SvCUR(cat);
4486                 while (aptr <= pat)
4487                     *aptr++ = '\0';
4488
4489                 pat = savepat;
4490                 items = saveitems;
4491             }
4492             break;
4493         case 'C':
4494         case 'c':
4495             while (len-- > 0) {
4496                 fromstr = NEXTFROM;
4497                 aint = SvIV(fromstr);
4498                 achar = aint;
4499                 sv_catpvn(cat, &achar, sizeof(char));
4500             }
4501             break;
4502         case 'U':
4503             while (len-- > 0) {
4504                 fromstr = NEXTFROM;
4505                 auint = SvUV(fromstr);
4506                 SvGROW(cat, SvCUR(cat) + 10);
4507                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4508                                - SvPVX(cat));
4509             }
4510             *SvEND(cat) = '\0';
4511             break;
4512         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4513         case 'f':
4514         case 'F':
4515             while (len-- > 0) {
4516                 fromstr = NEXTFROM;
4517                 afloat = (float)SvNV(fromstr);
4518                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4519             }
4520             break;
4521         case 'd':
4522         case 'D':
4523             while (len-- > 0) {
4524                 fromstr = NEXTFROM;
4525                 adouble = (double)SvNV(fromstr);
4526                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4527             }
4528             break;
4529         case 'n':
4530             while (len-- > 0) {
4531                 fromstr = NEXTFROM;
4532                 ashort = (I16)SvIV(fromstr);
4533 #ifdef HAS_HTONS
4534                 ashort = PerlSock_htons(ashort);
4535 #endif
4536                 CAT16(cat, &ashort);
4537             }
4538             break;
4539         case 'v':
4540             while (len-- > 0) {
4541                 fromstr = NEXTFROM;
4542                 ashort = (I16)SvIV(fromstr);
4543 #ifdef HAS_HTOVS
4544                 ashort = htovs(ashort);
4545 #endif
4546                 CAT16(cat, &ashort);
4547             }
4548             break;
4549         case 'S':
4550 #if SHORTSIZE != SIZE16
4551             if (natint) {
4552                 unsigned short aushort;
4553
4554                 while (len-- > 0) {
4555                     fromstr = NEXTFROM;
4556                     aushort = SvUV(fromstr);
4557                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4558                 }
4559             }
4560             else
4561 #endif
4562             {
4563                 U16 aushort;
4564
4565                 while (len-- > 0) {
4566                     fromstr = NEXTFROM;
4567                     aushort = (U16)SvUV(fromstr);
4568                     CAT16(cat, &aushort);
4569                 }
4570
4571             }
4572             break;
4573         case 's':
4574 #if SHORTSIZE != SIZE16
4575             if (natint) {
4576                 while (len-- > 0) {
4577                     fromstr = NEXTFROM;
4578                     ashort = SvIV(fromstr);
4579                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4580                 }
4581             }
4582             else
4583 #endif
4584             {
4585                 while (len-- > 0) {
4586                     fromstr = NEXTFROM;
4587                     ashort = (I16)SvIV(fromstr);
4588                     CAT16(cat, &ashort);
4589                 }
4590             }
4591             break;
4592         case 'I':
4593             while (len-- > 0) {
4594                 fromstr = NEXTFROM;
4595                 auint = SvUV(fromstr);
4596                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4597             }
4598             break;
4599         case 'w':
4600             while (len-- > 0) {
4601                 fromstr = NEXTFROM;
4602                 adouble = floor(SvNV(fromstr));
4603
4604                 if (adouble < 0)
4605                     croak("Cannot compress negative numbers");
4606
4607                 if (
4608 #ifdef BW_BITS
4609                     adouble <= BW_MASK
4610 #else
4611 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4612                     adouble <= UV_MAX_cxux
4613 #else
4614                     adouble <= UV_MAX
4615 #endif
4616 #endif
4617                     )
4618                 {
4619                     char   buf[1 + sizeof(UV)];
4620                     char  *in = buf + sizeof(buf);
4621                     UV     auv = U_V(adouble);;
4622
4623                     do {
4624                         *--in = (auv & 0x7f) | 0x80;
4625                         auv >>= 7;
4626                     } while (auv);
4627                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4628                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4629                 }
4630                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4631                     char           *from, *result, *in;
4632                     SV             *norm;
4633                     STRLEN          len;
4634                     bool            done;
4635
4636                     /* Copy string and check for compliance */
4637                     from = SvPV(fromstr, len);
4638                     if ((norm = is_an_int(from, len)) == NULL)
4639                         croak("can compress only unsigned integer");
4640
4641                     New('w', result, len, char);
4642                     in = result + len;
4643                     done = FALSE;
4644                     while (!done)
4645                         *--in = div128(norm, &done) | 0x80;
4646                     result[len - 1] &= 0x7F; /* clear continue bit */
4647                     sv_catpvn(cat, in, (result + len) - in);
4648                     Safefree(result);
4649                     SvREFCNT_dec(norm); /* free norm */
4650                 }
4651                 else if (SvNOKp(fromstr)) {
4652                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4653                     char  *in = buf + sizeof(buf);
4654
4655                     do {
4656                         double next = floor(adouble / 128);
4657                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4658                         if (--in < buf)  /* this cannot happen ;-) */
4659                             croak ("Cannot compress integer");
4660                         adouble = next;
4661                     } while (adouble > 0);
4662                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4663                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4664                 }
4665                 else
4666                     croak("Cannot compress non integer");
4667             }
4668             break;
4669         case 'i':
4670             while (len-- > 0) {
4671                 fromstr = NEXTFROM;
4672                 aint = SvIV(fromstr);
4673                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4674             }
4675             break;
4676         case 'N':
4677             while (len-- > 0) {
4678                 fromstr = NEXTFROM;
4679                 aulong = SvUV(fromstr);
4680 #ifdef HAS_HTONL
4681                 aulong = PerlSock_htonl(aulong);
4682 #endif
4683                 CAT32(cat, &aulong);
4684             }
4685             break;
4686         case 'V':
4687             while (len-- > 0) {
4688                 fromstr = NEXTFROM;
4689                 aulong = SvUV(fromstr);
4690 #ifdef HAS_HTOVL
4691                 aulong = htovl(aulong);
4692 #endif
4693                 CAT32(cat, &aulong);
4694             }
4695             break;
4696         case 'L':
4697 #if LONGSIZE != SIZE32
4698             if (natint) {
4699                 while (len-- > 0) {
4700                     fromstr = NEXTFROM;
4701                     aulong = SvUV(fromstr);
4702                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4703                 }
4704             }
4705             else
4706 #endif
4707             {
4708                 while (len-- > 0) {
4709                     fromstr = NEXTFROM;
4710                     aulong = SvUV(fromstr);
4711                     CAT32(cat, &aulong);
4712                 }
4713             }
4714             break;
4715         case 'l':
4716 #if LONGSIZE != SIZE32
4717             if (natint) {
4718                 while (len-- > 0) {
4719                     fromstr = NEXTFROM;
4720                     along = SvIV(fromstr);
4721                     sv_catpvn(cat, (char *)&along, sizeof(long));
4722                 }
4723             }
4724             else
4725 #endif
4726             {
4727                 while (len-- > 0) {
4728                     fromstr = NEXTFROM;
4729                     along = SvIV(fromstr);
4730                     CAT32(cat, &along);
4731                 }
4732             }
4733             break;
4734 #ifdef HAS_QUAD
4735         case 'Q':
4736             while (len-- > 0) {
4737                 fromstr = NEXTFROM;
4738                 auquad = (Uquad_t)SvIV(fromstr);
4739                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4740             }
4741             break;
4742         case 'q':
4743             while (len-- > 0) {
4744                 fromstr = NEXTFROM;
4745                 aquad = (Quad_t)SvIV(fromstr);
4746                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4747             }
4748             break;
4749 #endif /* HAS_QUAD */
4750         case 'P':
4751             len = 1;            /* assume SV is correct length */
4752             /* FALL THROUGH */
4753         case 'p':
4754             while (len-- > 0) {
4755                 fromstr = NEXTFROM;
4756                 if (fromstr == &PL_sv_undef)
4757                     aptr = NULL;
4758                 else {
4759                     STRLEN n_a;
4760                     /* XXX better yet, could spirit away the string to
4761                      * a safe spot and hang on to it until the result
4762                      * of pack() (and all copies of the result) are
4763                      * gone.
4764                      */
4765                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4766                         warner(WARN_UNSAFE,
4767                                 "Attempt to pack pointer to temporary value");
4768                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4769                         aptr = SvPV(fromstr,n_a);
4770                     else
4771                         aptr = SvPV_force(fromstr,n_a);
4772                 }
4773                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4774             }
4775             break;
4776         case 'u':
4777             fromstr = NEXTFROM;
4778             aptr = SvPV(fromstr, fromlen);
4779             SvGROW(cat, fromlen * 4 / 3);
4780             if (len <= 1)
4781                 len = 45;
4782             else
4783                 len = len / 3 * 3;
4784             while (fromlen > 0) {
4785                 I32 todo;
4786
4787                 if (fromlen > len)
4788                     todo = len;
4789                 else
4790                     todo = fromlen;
4791                 doencodes(cat, aptr, todo);
4792                 fromlen -= todo;
4793                 aptr += todo;
4794             }
4795             break;
4796         }
4797     }
4798     SvSETMAGIC(cat);
4799     SP = ORIGMARK;
4800     PUSHs(cat);
4801     RETURN;
4802 }
4803 #undef NEXTFROM
4804
4805
4806 PP(pp_split)
4807 {
4808     djSP; dTARG;
4809     AV *ary;
4810     register I32 limit = POPi;                  /* note, negative is forever */
4811     SV *sv = POPs;
4812     STRLEN len;
4813     register char *s = SvPV(sv, len);
4814     char *strend = s + len;
4815     register PMOP *pm;
4816     register REGEXP *rx;
4817     register SV *dstr;
4818     register char *m;
4819     I32 iters = 0;
4820     I32 maxiters = (strend - s) + 10;
4821     I32 i;
4822     char *orig;
4823     I32 origlimit = limit;
4824     I32 realarray = 0;
4825     I32 base;
4826     AV *oldstack = PL_curstack;
4827     I32 gimme = GIMME_V;
4828     I32 oldsave = PL_savestack_ix;
4829     I32 make_mortal = 1;
4830     MAGIC *mg = (MAGIC *) NULL;
4831
4832 #ifdef DEBUGGING
4833     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4834 #else
4835     pm = (PMOP*)POPs;
4836 #endif
4837     if (!pm || !s)
4838         DIE("panic: do_split");
4839     rx = pm->op_pmregexp;
4840
4841     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4842              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4843
4844     if (pm->op_pmreplroot)
4845         ary = GvAVn((GV*)pm->op_pmreplroot);
4846     else if (gimme != G_ARRAY)
4847 #ifdef USE_THREADS
4848         ary = (AV*)PL_curpad[0];
4849 #else
4850         ary = GvAVn(PL_defgv);
4851 #endif /* USE_THREADS */
4852     else
4853         ary = Nullav;
4854     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4855         realarray = 1;
4856         PUTBACK;
4857         av_extend(ary,0);
4858         av_clear(ary);
4859         SPAGAIN;
4860         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4861             PUSHMARK(SP);
4862             XPUSHs(SvTIED_obj((SV*)ary, mg));
4863         }
4864         else {
4865             if (!AvREAL(ary)) {
4866                 AvREAL_on(ary);
4867                 for (i = AvFILLp(ary); i >= 0; i--)
4868                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4869             }
4870             /* temporarily switch stacks */
4871             SWITCHSTACK(PL_curstack, ary);
4872             make_mortal = 0;
4873         }
4874     }
4875     base = SP - PL_stack_base;
4876     orig = s;
4877     if (pm->op_pmflags & PMf_SKIPWHITE) {
4878         if (pm->op_pmflags & PMf_LOCALE) {
4879             while (isSPACE_LC(*s))
4880                 s++;
4881         }
4882         else {
4883             while (isSPACE(*s))
4884                 s++;
4885         }
4886     }
4887     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4888         SAVEINT(PL_multiline);
4889         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4890     }
4891
4892     if (!limit)
4893         limit = maxiters + 2;
4894     if (pm->op_pmflags & PMf_WHITE) {
4895         while (--limit) {
4896             m = s;
4897             while (m < strend &&
4898                    !((pm->op_pmflags & PMf_LOCALE)
4899                      ? isSPACE_LC(*m) : isSPACE(*m)))
4900                 ++m;
4901             if (m >= strend)
4902                 break;
4903
4904             dstr = NEWSV(30, m-s);
4905             sv_setpvn(dstr, s, m-s);
4906             if (make_mortal)
4907                 sv_2mortal(dstr);
4908             XPUSHs(dstr);
4909
4910             s = m + 1;
4911             while (s < strend &&
4912                    ((pm->op_pmflags & PMf_LOCALE)
4913                     ? isSPACE_LC(*s) : isSPACE(*s)))
4914                 ++s;
4915         }
4916     }
4917     else if (strEQ("^", rx->precomp)) {
4918         while (--limit) {
4919             /*SUPPRESS 530*/
4920             for (m = s; m < strend && *m != '\n'; m++) ;
4921             m++;
4922             if (m >= strend)
4923                 break;
4924             dstr = NEWSV(30, m-s);
4925             sv_setpvn(dstr, s, m-s);
4926             if (make_mortal)
4927                 sv_2mortal(dstr);
4928             XPUSHs(dstr);
4929             s = m;
4930         }
4931     }
4932     else if (rx->check_substr && !rx->nparens
4933              && (rx->reganch & ROPT_CHECK_ALL)
4934              && !(rx->reganch & ROPT_ANCH)) {
4935         i = SvCUR(rx->check_substr);
4936         if (i == 1 && !SvTAIL(rx->check_substr)) {
4937             i = *SvPVX(rx->check_substr);
4938             while (--limit) {
4939                 /*SUPPRESS 530*/
4940                 for (m = s; m < strend && *m != i; m++) ;
4941                 if (m >= strend)
4942                     break;
4943                 dstr = NEWSV(30, m-s);
4944                 sv_setpvn(dstr, s, m-s);
4945                 if (make_mortal)
4946                     sv_2mortal(dstr);
4947                 XPUSHs(dstr);
4948                 s = m + 1;
4949             }
4950         }
4951         else {
4952 #ifndef lint
4953             while (s < strend && --limit &&
4954               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4955                     rx->check_substr, 0)) )
4956 #endif
4957             {
4958                 dstr = NEWSV(31, m-s);
4959                 sv_setpvn(dstr, s, m-s);
4960                 if (make_mortal)
4961                     sv_2mortal(dstr);
4962                 XPUSHs(dstr);
4963                 s = m + i;
4964             }
4965         }
4966     }
4967     else {
4968         maxiters += (strend - s) * rx->nparens;
4969         while (s < strend && --limit &&
4970                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4971         {
4972             TAINT_IF(RX_MATCH_TAINTED(rx));
4973             if (rx->subbase
4974               && rx->subbase != orig) {
4975                 m = s;
4976                 s = orig;
4977                 orig = rx->subbase;
4978                 s = orig + (m - s);
4979                 strend = s + (strend - m);
4980             }
4981             m = rx->startp[0];
4982             dstr = NEWSV(32, m-s);
4983             sv_setpvn(dstr, s, m-s);
4984             if (make_mortal)
4985                 sv_2mortal(dstr);
4986             XPUSHs(dstr);
4987             if (rx->nparens) {
4988                 for (i = 1; i <= rx->nparens; i++) {
4989                     s = rx->startp[i];
4990                     m = rx->endp[i];
4991                     if (m && s) {
4992                         dstr = NEWSV(33, m-s);
4993                         sv_setpvn(dstr, s, m-s);
4994                     }
4995                     else
4996                         dstr = NEWSV(33, 0);
4997                     if (make_mortal)
4998                         sv_2mortal(dstr);
4999                     XPUSHs(dstr);
5000                 }
5001             }
5002             s = rx->endp[0];
5003         }
5004     }
5005
5006     LEAVE_SCOPE(oldsave);
5007     iters = (SP - PL_stack_base) - base;
5008     if (iters > maxiters)
5009         DIE("Split loop");
5010
5011     /* keep field after final delim? */
5012     if (s < strend || (iters && origlimit)) {
5013         dstr = NEWSV(34, strend-s);
5014         sv_setpvn(dstr, s, strend-s);
5015         if (make_mortal)
5016             sv_2mortal(dstr);
5017         XPUSHs(dstr);
5018         iters++;
5019     }
5020     else if (!origlimit) {
5021         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5022             iters--, SP--;
5023     }
5024
5025     if (realarray) {
5026         if (!mg) {
5027             SWITCHSTACK(ary, oldstack);
5028             if (SvSMAGICAL(ary)) {
5029                 PUTBACK;
5030                 mg_set((SV*)ary);
5031                 SPAGAIN;
5032             }
5033             if (gimme == G_ARRAY) {
5034                 EXTEND(SP, iters);
5035                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5036                 SP += iters;
5037                 RETURN;
5038             }
5039         }
5040         else {
5041             PUTBACK;
5042             ENTER;
5043             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5044             LEAVE;
5045             SPAGAIN;
5046             if (gimme == G_ARRAY) {
5047                 /* EXTEND should not be needed - we just popped them */
5048                 EXTEND(SP, iters);
5049                 for (i=0; i < iters; i++) {
5050                     SV **svp = av_fetch(ary, i, FALSE);
5051                     PUSHs((svp) ? *svp : &PL_sv_undef);
5052                 }
5053                 RETURN;
5054             }
5055         }
5056     }
5057     else {
5058         if (gimme == G_ARRAY)
5059             RETURN;
5060     }
5061     if (iters || !pm->op_pmreplroot) {
5062         GETTARGET;
5063         PUSHi(iters);
5064         RETURN;
5065     }
5066     RETPUSHUNDEF;
5067 }
5068
5069 #ifdef USE_THREADS
5070 void
5071 unlock_condpair(void *svv)
5072 {
5073     dTHR;
5074     MAGIC *mg = mg_find((SV*)svv, 'm');
5075
5076     if (!mg)
5077         croak("panic: unlock_condpair unlocking non-mutex");
5078     MUTEX_LOCK(MgMUTEXP(mg));
5079     if (MgOWNER(mg) != thr)
5080         croak("panic: unlock_condpair unlocking mutex that we don't own");
5081     MgOWNER(mg) = 0;
5082     COND_SIGNAL(MgOWNERCONDP(mg));
5083     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5084                           (unsigned long)thr, (unsigned long)svv);)
5085     MUTEX_UNLOCK(MgMUTEXP(mg));
5086 }
5087 #endif /* USE_THREADS */
5088
5089 PP(pp_lock)
5090 {
5091     djSP;
5092     dTOPss;
5093     SV *retsv = sv;
5094 #ifdef USE_THREADS
5095     MAGIC *mg;
5096
5097     if (SvROK(sv))
5098         sv = SvRV(sv);
5099
5100     mg = condpair_magic(sv);
5101     MUTEX_LOCK(MgMUTEXP(mg));
5102     if (MgOWNER(mg) == thr)
5103         MUTEX_UNLOCK(MgMUTEXP(mg));
5104     else {
5105         while (MgOWNER(mg))
5106             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5107         MgOWNER(mg) = thr;
5108         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5109                               (unsigned long)thr, (unsigned long)sv);)
5110         MUTEX_UNLOCK(MgMUTEXP(mg));
5111         save_destructor(unlock_condpair, sv);
5112     }
5113 #endif /* USE_THREADS */
5114     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5115         || SvTYPE(retsv) == SVt_PVCV) {
5116         retsv = refto(retsv);
5117     }
5118     SETs(retsv);
5119     RETURN;
5120 }
5121
5122 PP(pp_threadsv)
5123 {
5124     djSP;
5125 #ifdef USE_THREADS
5126     EXTEND(SP, 1);
5127     if (PL_op->op_private & OPpLVAL_INTRO)
5128         PUSHs(*save_threadsv(PL_op->op_targ));
5129     else
5130         PUSHs(THREADSV(PL_op->op_targ));
5131     RETURN;
5132 #else
5133     DIE("tried to access per-thread data in non-threaded perl");
5134 #endif /* USE_THREADS */
5135 }