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