pp.c

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