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     else
1843         utfcurlen = 0;
1844
1845     if (pos >= arybase) {
1846         pos -= arybase;
1847         rem = curlen-pos;
1848         fail = rem;
1849         if (MAXARG > 2) {
1850             if (len < 0) {
1851                 rem += len;
1852                 if (rem < 0)
1853                     rem = 0;
1854             }
1855             else if (rem > len)
1856                      rem = len;
1857         }
1858     }
1859     else {
1860         pos += curlen;
1861         if (MAXARG < 3)
1862             rem = curlen;
1863         else if (len >= 0) {
1864             rem = pos+len;
1865             if (rem > (I32)curlen)
1866                 rem = curlen;
1867         }
1868         else {
1869             rem = curlen+len;
1870             if (rem < pos)
1871                 rem = pos;
1872         }
1873         if (pos < 0)
1874             pos = 0;
1875         fail = rem;
1876         rem -= pos;
1877     }
1878     if (fail < 0) {
1879         if (PL_dowarn || lvalue || repl)
1880             warn("substr outside of string");
1881         RETPUSHUNDEF;
1882     }
1883     else {
1884         if (utfcurlen)
1885             sv_pos_u2b(sv, &pos, &rem);
1886         tmps += pos;
1887         sv_setpvn(TARG, tmps, rem);
1888         if (lvalue) {                   /* it's an lvalue! */
1889             if (!SvGMAGICAL(sv)) {
1890                 if (SvROK(sv)) {
1891                     SvPV_force(sv,PL_na);
1892                     if (PL_dowarn)
1893                         warn("Attempt to use reference as lvalue in substr");
1894                 }
1895                 if (SvOK(sv))           /* is it defined ? */
1896                     (void)SvPOK_only(sv);
1897                 else
1898                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1899             }
1900
1901             if (SvTYPE(TARG) < SVt_PVLV) {
1902                 sv_upgrade(TARG, SVt_PVLV);
1903                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1904             }
1905
1906             LvTYPE(TARG) = 'x';
1907             if (LvTARG(TARG) != sv) {
1908                 if (LvTARG(TARG))
1909                     SvREFCNT_dec(LvTARG(TARG));
1910                 LvTARG(TARG) = SvREFCNT_inc(sv);
1911             }
1912             LvTARGOFF(TARG) = pos;
1913             LvTARGLEN(TARG) = rem;
1914         }
1915         else if (repl)
1916             sv_insert(sv, pos, rem, repl, repl_len);
1917     }
1918     SPAGAIN;
1919     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1920     RETURN;
1921 }
1922
1923 PP(pp_vec)
1924 {
1925     djSP; dTARGET;
1926     register I32 size = POPi;
1927     register I32 offset = POPi;
1928     register SV *src = POPs;
1929     I32 lvalue = PL_op->op_flags & OPf_MOD;
1930     STRLEN srclen;
1931     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1932     unsigned long retnum;
1933     I32 len;
1934
1935     SvTAINTED_off(TARG);                        /* decontaminate */
1936     offset *= size;             /* turn into bit offset */
1937     len = (offset + size + 7) / 8;
1938     if (offset < 0 || size < 1)
1939         retnum = 0;
1940     else {
1941         if (lvalue) {                      /* it's an lvalue! */
1942             if (SvTYPE(TARG) < SVt_PVLV) {
1943                 sv_upgrade(TARG, SVt_PVLV);
1944                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1945             }
1946
1947             LvTYPE(TARG) = 'v';
1948             if (LvTARG(TARG) != src) {
1949                 if (LvTARG(TARG))
1950                     SvREFCNT_dec(LvTARG(TARG));
1951                 LvTARG(TARG) = SvREFCNT_inc(src);
1952             }
1953             LvTARGOFF(TARG) = offset;
1954             LvTARGLEN(TARG) = size;
1955         }
1956         if (len > srclen) {
1957             if (size <= 8)
1958                 retnum = 0;
1959             else {
1960                 offset >>= 3;
1961                 if (size == 16) {
1962                     if (offset >= srclen)
1963                         retnum = 0;
1964                     else
1965                         retnum = (unsigned long) s[offset] << 8;
1966                 }
1967                 else if (size == 32) {
1968                     if (offset >= srclen)
1969                         retnum = 0;
1970                     else if (offset + 1 >= srclen)
1971                         retnum = (unsigned long) s[offset] << 24;
1972                     else if (offset + 2 >= srclen)
1973                         retnum = ((unsigned long) s[offset] << 24) +
1974                             ((unsigned long) s[offset + 1] << 16);
1975                     else
1976                         retnum = ((unsigned long) s[offset] << 24) +
1977                             ((unsigned long) s[offset + 1] << 16) +
1978                             (s[offset + 2] << 8);
1979                 }
1980             }
1981         }
1982         else if (size < 8)
1983             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1984         else {
1985             offset >>= 3;
1986             if (size == 8)
1987                 retnum = s[offset];
1988             else if (size == 16)
1989                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1990             else if (size == 32)
1991                 retnum = ((unsigned long) s[offset] << 24) +
1992                         ((unsigned long) s[offset + 1] << 16) +
1993                         (s[offset + 2] << 8) + s[offset+3];
1994         }
1995     }
1996
1997     sv_setuv(TARG, (UV)retnum);
1998     PUSHs(TARG);
1999     RETURN;
2000 }
2001
2002 PP(pp_index)
2003 {
2004     djSP; dTARGET;
2005     SV *big;
2006     SV *little;
2007     I32 offset;
2008     I32 retval;
2009     char *tmps;
2010     char *tmps2;
2011     STRLEN biglen;
2012     I32 arybase = PL_curcop->cop_arybase;
2013
2014     if (MAXARG < 3)
2015         offset = 0;
2016     else
2017         offset = POPi - arybase;
2018     little = POPs;
2019     big = POPs;
2020     tmps = SvPV(big, biglen);
2021     if (IN_UTF8 && offset > 0)
2022         sv_pos_u2b(big, &offset, 0);
2023     if (offset < 0)
2024         offset = 0;
2025     else if (offset > biglen)
2026         offset = biglen;
2027     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2028       (unsigned char*)tmps + biglen, little, 0)))
2029         retval = -1;
2030     else
2031         retval = tmps2 - tmps;
2032     if (IN_UTF8 && retval > 0)
2033         sv_pos_b2u(big, &retval);
2034     PUSHi(retval + arybase);
2035     RETURN;
2036 }
2037
2038 PP(pp_rindex)
2039 {
2040     djSP; dTARGET;
2041     SV *big;
2042     SV *little;
2043     STRLEN blen;
2044     STRLEN llen;
2045     I32 offset;
2046     I32 retval;
2047     char *tmps;
2048     char *tmps2;
2049     I32 arybase = PL_curcop->cop_arybase;
2050
2051     if (MAXARG >= 3)
2052         offset = POPi;
2053     little = POPs;
2054     big = POPs;
2055     tmps2 = SvPV(little, llen);
2056     tmps = SvPV(big, blen);
2057     if (MAXARG < 3)
2058         offset = blen;
2059     else {
2060         if (IN_UTF8 && offset > 0)
2061             sv_pos_u2b(big, &offset, 0);
2062         offset = offset - arybase + llen;
2063     }
2064     if (offset < 0)
2065         offset = 0;
2066     else if (offset > blen)
2067         offset = blen;
2068     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2069                           tmps2, tmps2 + llen)))
2070         retval = -1;
2071     else
2072         retval = tmps2 - tmps;
2073     if (IN_UTF8 && retval > 0)
2074         sv_pos_b2u(big, &retval);
2075     PUSHi(retval + arybase);
2076     RETURN;
2077 }
2078
2079 PP(pp_sprintf)
2080 {
2081     djSP; dMARK; dORIGMARK; dTARGET;
2082 #ifdef USE_LOCALE_NUMERIC
2083     if (PL_op->op_private & OPpLOCALE)
2084         SET_NUMERIC_LOCAL();
2085     else
2086         SET_NUMERIC_STANDARD();
2087 #endif
2088     do_sprintf(TARG, SP-MARK, MARK+1);
2089     TAINT_IF(SvTAINTED(TARG));
2090     SP = ORIGMARK;
2091     PUSHTARG;
2092     RETURN;
2093 }
2094
2095 PP(pp_ord)
2096 {
2097     djSP; dTARGET;
2098     I32 value;
2099     char *tmps = POPp;
2100     I32 retlen;
2101
2102     if (IN_UTF8 && (*tmps & 0x80))
2103         value = (I32) utf8_to_uv(tmps, &retlen);
2104     else
2105         value = (I32) (*tmps & 255);
2106     XPUSHi(value);
2107     RETURN;
2108 }
2109
2110 PP(pp_chr)
2111 {
2112     djSP; dTARGET;
2113     char *tmps;
2114     I32 value = POPi;
2115
2116     (void)SvUPGRADE(TARG,SVt_PV);
2117
2118     if (IN_UTF8 && value >= 128) {
2119         SvGROW(TARG,8);
2120         tmps = SvPVX(TARG);
2121         tmps = uv_to_utf8(tmps, (UV)value);
2122         SvCUR_set(TARG, tmps - SvPVX(TARG));
2123         *tmps = '\0';
2124         (void)SvPOK_only(TARG);
2125         XPUSHs(TARG);
2126         RETURN;
2127     }
2128
2129     SvGROW(TARG,2);
2130     SvCUR_set(TARG, 1);
2131     tmps = SvPVX(TARG);
2132     *tmps++ = value;
2133     *tmps = '\0';
2134     (void)SvPOK_only(TARG);
2135     XPUSHs(TARG);
2136     RETURN;
2137 }
2138
2139 PP(pp_crypt)
2140 {
2141     djSP; dTARGET; dPOPTOPssrl;
2142 #ifdef HAS_CRYPT
2143     char *tmps = SvPV(left, PL_na);
2144 #ifdef FCRYPT
2145     sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2146 #else
2147     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2148 #endif
2149 #else
2150     DIE(
2151       "The crypt() function is unimplemented due to excessive paranoia.");
2152 #endif
2153     SETs(TARG);
2154     RETURN;
2155 }
2156
2157 PP(pp_ucfirst)
2158 {
2159     djSP;
2160     SV *sv = TOPs;
2161     register U8 *s;
2162     STRLEN slen;
2163
2164     if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2165         I32 ulen;
2166         U8 tmpbuf[10];
2167         U8 *tend;
2168         UV uv = utf8_to_uv(s, &ulen);
2169
2170         if (PL_op->op_private & OPpLOCALE) {
2171             TAINT;
2172             SvTAINTED_on(sv);
2173             uv = toTITLE_LC_uni(uv);
2174         }
2175         else
2176             uv = toTITLE_utf8(s);
2177
2178         tend = uv_to_utf8(tmpbuf, uv);
2179
2180         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2181             dTARGET;
2182             sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2183             sv_catpvn(TARG, s + ulen, slen - ulen);
2184             SETs(TARG);
2185         }
2186         else {
2187             s = SvPV_force(sv, slen);
2188             Copy(tmpbuf, s, ulen, U8);
2189         }
2190         RETURN;
2191     }
2192
2193     if (!SvPADTMP(sv)) {
2194         dTARGET;
2195         sv_setsv(TARG, sv);
2196         sv = TARG;
2197         SETs(sv);
2198     }
2199     s = SvPV_force(sv, PL_na);
2200     if (*s) {
2201         if (PL_op->op_private & OPpLOCALE) {
2202             TAINT;
2203             SvTAINTED_on(sv);
2204             *s = toUPPER_LC(*s);
2205         }
2206         else
2207             *s = toUPPER(*s);
2208     }
2209
2210     RETURN;
2211 }
2212
2213 PP(pp_lcfirst)
2214 {
2215     djSP;
2216     SV *sv = TOPs;
2217     register U8 *s;
2218     STRLEN slen;
2219
2220     if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2221         I32 ulen;
2222         U8 tmpbuf[10];
2223         U8 *tend;
2224         UV uv = utf8_to_uv(s, &ulen);
2225
2226         if (PL_op->op_private & OPpLOCALE) {
2227             TAINT;
2228             SvTAINTED_on(sv);
2229             uv = toLOWER_LC_uni(uv);
2230         }
2231         else
2232             uv = toLOWER_utf8(s);
2233
2234         tend = uv_to_utf8(tmpbuf, uv);
2235
2236         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2237             dTARGET;
2238             sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2239             sv_catpvn(TARG, s + ulen, slen - ulen);
2240             SETs(TARG);
2241         }
2242         else {
2243             s = SvPV_force(sv, slen);
2244             Copy(tmpbuf, s, ulen, U8);
2245         }
2246         RETURN;
2247     }
2248
2249     if (!SvPADTMP(sv)) {
2250         dTARGET;
2251         sv_setsv(TARG, sv);
2252         sv = TARG;
2253         SETs(sv);
2254     }
2255     s = SvPV_force(sv, PL_na);
2256     if (*s) {
2257         if (PL_op->op_private & OPpLOCALE) {
2258             TAINT;
2259             SvTAINTED_on(sv);
2260             *s = toLOWER_LC(*s);
2261         }
2262         else
2263             *s = toLOWER(*s);
2264     }
2265
2266     SETs(sv);
2267     RETURN;
2268 }
2269
2270 PP(pp_uc)
2271 {
2272     djSP;
2273     SV *sv = TOPs;
2274     register U8 *s;
2275     STRLEN len;
2276
2277     if (IN_UTF8) {
2278         dTARGET;
2279         I32 ulen;
2280         register U8 *d;
2281         U8 *send;
2282
2283         s = SvPV(sv,len);
2284         if (!len)
2285             RETURN;
2286
2287         (void)SvUPGRADE(TARG, SVt_PV);
2288         SvGROW(TARG, (len * 2) + 1);
2289         (void)SvPOK_only(TARG);
2290         d = SvPVX(TARG);
2291         send = s + len;
2292         if (PL_op->op_private & OPpLOCALE) {
2293             TAINT;
2294             SvTAINTED_on(TARG);
2295             while (s < send) {
2296                 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2297                 s += ulen;
2298             }
2299         }
2300         else {
2301             while (s < send) {
2302                 d = uv_to_utf8(d, toUPPER_utf8( s ));
2303                 s += UTF8SKIP(s);
2304             }
2305         }
2306         *d = '\0';
2307         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2308         SETs(TARG);
2309         RETURN;
2310     }
2311
2312     if (!SvPADTMP(sv)) {
2313         dTARGET;
2314         sv_setsv(TARG, sv);
2315         sv = TARG;
2316         SETs(sv);
2317     }
2318
2319     s = SvPV_force(sv, len);
2320     if (len) {
2321         register U8 *send = s + len;
2322
2323         if (PL_op->op_private & OPpLOCALE) {
2324             TAINT;
2325             SvTAINTED_on(sv);
2326             for (; s < send; s++)
2327                 *s = toUPPER_LC(*s);
2328         }
2329         else {
2330             for (; s < send; s++)
2331                 *s = toUPPER(*s);
2332         }
2333     }
2334     RETURN;
2335 }
2336
2337 PP(pp_lc)
2338 {
2339     djSP;
2340     SV *sv = TOPs;
2341     register U8 *s;
2342     STRLEN len;
2343
2344     if (IN_UTF8) {
2345         dTARGET;
2346         I32 ulen;
2347         register U8 *d;
2348         U8 *send;
2349
2350         s = SvPV(sv,len);
2351         if (!len)
2352             RETURN;
2353
2354         (void)SvUPGRADE(TARG, SVt_PV);
2355         SvGROW(TARG, (len * 2) + 1);
2356         (void)SvPOK_only(TARG);
2357         d = SvPVX(TARG);
2358         send = s + len;
2359         if (PL_op->op_private & OPpLOCALE) {
2360             TAINT;
2361             SvTAINTED_on(TARG);
2362             while (s < send) {
2363                 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2364                 s += ulen;
2365             }
2366         }
2367         else {
2368             while (s < send) {
2369                 d = uv_to_utf8(d, toLOWER_utf8(s));
2370                 s += UTF8SKIP(s);
2371             }
2372         }
2373         *d = '\0';
2374         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2375         SETs(TARG);
2376         RETURN;
2377     }
2378
2379     if (!SvPADTMP(sv)) {
2380         dTARGET;
2381         sv_setsv(TARG, sv);
2382         sv = TARG;
2383         SETs(sv);
2384     }
2385
2386     s = SvPV_force(sv, len);
2387     if (len) {
2388         register U8 *send = s + len;
2389
2390         if (PL_op->op_private & OPpLOCALE) {
2391             TAINT;
2392             SvTAINTED_on(sv);
2393             for (; s < send; s++)
2394                 *s = toLOWER_LC(*s);
2395         }
2396         else {
2397             for (; s < send; s++)
2398                 *s = toLOWER(*s);
2399         }
2400     }
2401     RETURN;
2402 }
2403
2404 PP(pp_quotemeta)
2405 {
2406     djSP; dTARGET;
2407     SV *sv = TOPs;
2408     STRLEN len;
2409     register char *s = SvPV(sv,len);
2410     register char *d;
2411
2412     if (len) {
2413         (void)SvUPGRADE(TARG, SVt_PV);
2414         SvGROW(TARG, (len * 2) + 1);
2415         d = SvPVX(TARG);
2416         while (len--) {
2417             if (!(*s & 0x80) && !isALNUM(*s))
2418                 *d++ = '\\';
2419             *d++ = *s++;
2420         }
2421         *d = '\0';
2422         SvCUR_set(TARG, d - SvPVX(TARG));
2423         (void)SvPOK_only(TARG);
2424     }
2425     else
2426         sv_setpvn(TARG, s, len);
2427     SETs(TARG);
2428     RETURN;
2429 }
2430
2431 /* Arrays. */
2432
2433 PP(pp_aslice)
2434 {
2435     djSP; dMARK; dORIGMARK;
2436     register SV** svp;
2437     register AV* av = (AV*)POPs;
2438     register I32 lval = PL_op->op_flags & OPf_MOD;
2439     I32 arybase = PL_curcop->cop_arybase;
2440     I32 elem;
2441
2442     if (SvTYPE(av) == SVt_PVAV) {
2443         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2444             I32 max = -1;
2445             for (svp = MARK + 1; svp <= SP; svp++) {
2446                 elem = SvIVx(*svp);
2447                 if (elem > max)
2448                     max = elem;
2449             }
2450             if (max > AvMAX(av))
2451                 av_extend(av, max);
2452         }
2453         while (++MARK <= SP) {
2454             elem = SvIVx(*MARK);
2455
2456             if (elem > 0)
2457                 elem -= arybase;
2458             svp = av_fetch(av, elem, lval);
2459             if (lval) {
2460                 if (!svp || *svp == &PL_sv_undef)
2461                     DIE(no_aelem, elem);
2462                 if (PL_op->op_private & OPpLVAL_INTRO)
2463                     save_aelem(av, elem, svp);
2464             }
2465             *MARK = svp ? *svp : &PL_sv_undef;
2466         }
2467     }
2468     if (GIMME != G_ARRAY) {
2469         MARK = ORIGMARK;
2470         *++MARK = *SP;
2471         SP = MARK;
2472     }
2473     RETURN;
2474 }
2475
2476 /* Associative arrays. */
2477
2478 PP(pp_each)
2479 {
2480     djSP; dTARGET;
2481     HV *hash = (HV*)POPs;
2482     HE *entry;
2483     I32 gimme = GIMME_V;
2484     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2485
2486     PUTBACK;
2487     /* might clobber stack_sp */
2488     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2489     SPAGAIN;
2490
2491     EXTEND(SP, 2);
2492     if (entry) {
2493         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2494         if (gimme == G_ARRAY) {
2495             PUTBACK;
2496             /* might clobber stack_sp */
2497             sv_setsv(TARG, realhv ?
2498                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2499             SPAGAIN;
2500             PUSHs(TARG);
2501         }
2502     }
2503     else if (gimme == G_SCALAR)
2504         RETPUSHUNDEF;
2505
2506     RETURN;
2507 }
2508
2509 PP(pp_values)
2510 {
2511     return do_kv(ARGS);
2512 }
2513
2514 PP(pp_keys)
2515 {
2516     return do_kv(ARGS);
2517 }
2518
2519 PP(pp_delete)
2520 {
2521     djSP;
2522     I32 gimme = GIMME_V;
2523     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2524     SV *sv;
2525     HV *hv;
2526
2527     if (PL_op->op_private & OPpSLICE) {
2528         dMARK; dORIGMARK;
2529         U32 hvtype;
2530         hv = (HV*)POPs;
2531         hvtype = SvTYPE(hv);
2532         while (++MARK <= SP) {
2533             if (hvtype == SVt_PVHV)
2534                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2535             else
2536                 DIE("Not a HASH reference");
2537             *MARK = sv ? sv : &PL_sv_undef;
2538         }
2539         if (discard)
2540             SP = ORIGMARK;
2541         else if (gimme == G_SCALAR) {
2542             MARK = ORIGMARK;
2543             *++MARK = *SP;
2544             SP = MARK;
2545         }
2546     }
2547     else {
2548         SV *keysv = POPs;
2549         hv = (HV*)POPs;
2550         if (SvTYPE(hv) == SVt_PVHV)
2551             sv = hv_delete_ent(hv, keysv, discard, 0);
2552         else
2553             DIE("Not a HASH reference");
2554         if (!sv)
2555             sv = &PL_sv_undef;
2556         if (!discard)
2557             PUSHs(sv);
2558     }
2559     RETURN;
2560 }
2561
2562 PP(pp_exists)
2563 {
2564     djSP;
2565     SV *tmpsv = POPs;
2566     HV *hv = (HV*)POPs;
2567     if (SvTYPE(hv) == SVt_PVHV) {
2568         if (hv_exists_ent(hv, tmpsv, 0))
2569             RETPUSHYES;
2570     } else if (SvTYPE(hv) == SVt_PVAV) {
2571         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2572             RETPUSHYES;
2573     } else {
2574         DIE("Not a HASH reference");
2575     }
2576     RETPUSHNO;
2577 }
2578
2579 PP(pp_hslice)
2580 {
2581     djSP; dMARK; dORIGMARK;
2582     register HV *hv = (HV*)POPs;
2583     register I32 lval = PL_op->op_flags & OPf_MOD;
2584     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2585
2586     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2587         DIE("Can't localize pseudo-hash element");
2588
2589     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2590         while (++MARK <= SP) {
2591             SV *keysv = *MARK;
2592             SV **svp;
2593             if (realhv) {
2594                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2595                 svp = he ? &HeVAL(he) : 0;
2596             } else {
2597                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2598             }
2599             if (lval) {
2600                 if (!svp || *svp == &PL_sv_undef)
2601                     DIE(no_helem, SvPV(keysv, PL_na));
2602                 if (PL_op->op_private & OPpLVAL_INTRO)
2603                     save_helem(hv, keysv, svp);
2604             }
2605             *MARK = svp ? *svp : &PL_sv_undef;
2606         }
2607     }
2608     if (GIMME != G_ARRAY) {
2609         MARK = ORIGMARK;
2610         *++MARK = *SP;
2611         SP = MARK;
2612     }
2613     RETURN;
2614 }
2615
2616 /* List operators. */
2617
2618 PP(pp_list)
2619 {
2620     djSP; dMARK;
2621     if (GIMME != G_ARRAY) {
2622         if (++MARK <= SP)
2623             *MARK = *SP;                /* unwanted list, return last item */
2624         else
2625             *MARK = &PL_sv_undef;
2626         SP = MARK;
2627     }
2628     RETURN;
2629 }
2630
2631 PP(pp_lslice)
2632 {
2633     djSP;
2634     SV **lastrelem = PL_stack_sp;
2635     SV **lastlelem = PL_stack_base + POPMARK;
2636     SV **firstlelem = PL_stack_base + POPMARK + 1;
2637     register SV **firstrelem = lastlelem + 1;
2638     I32 arybase = PL_curcop->cop_arybase;
2639     I32 lval = PL_op->op_flags & OPf_MOD;
2640     I32 is_something_there = lval;
2641
2642     register I32 max = lastrelem - lastlelem;
2643     register SV **lelem;
2644     register I32 ix;
2645
2646     if (GIMME != G_ARRAY) {
2647         ix = SvIVx(*lastlelem);
2648         if (ix < 0)
2649             ix += max;
2650         else
2651             ix -= arybase;
2652         if (ix < 0 || ix >= max)
2653             *firstlelem = &PL_sv_undef;
2654         else
2655             *firstlelem = firstrelem[ix];
2656         SP = firstlelem;
2657         RETURN;
2658     }
2659
2660     if (max == 0) {
2661         SP = firstlelem - 1;
2662         RETURN;
2663     }
2664
2665     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2666         ix = SvIVx(*lelem);
2667         if (ix < 0) {
2668             ix += max;
2669             if (ix < 0)
2670                 *lelem = &PL_sv_undef;
2671             else if (!(*lelem = firstrelem[ix]))
2672                 *lelem = &PL_sv_undef;
2673         }
2674         else {
2675             ix -= arybase;
2676             if (ix >= max || !(*lelem = firstrelem[ix]))
2677                 *lelem = &PL_sv_undef;
2678         }
2679         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2680             is_something_there = TRUE;
2681     }
2682     if (is_something_there)
2683         SP = lastlelem;
2684     else
2685         SP = firstlelem - 1;
2686     RETURN;
2687 }
2688
2689 PP(pp_anonlist)
2690 {
2691     djSP; dMARK; dORIGMARK;
2692     I32 items = SP - MARK;
2693     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2694     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2695     XPUSHs(av);
2696     RETURN;
2697 }
2698
2699 PP(pp_anonhash)
2700 {
2701     djSP; dMARK; dORIGMARK;
2702     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2703
2704     while (MARK < SP) {
2705         SV* key = *++MARK;
2706         SV *val = NEWSV(46, 0);
2707         if (MARK < SP)
2708             sv_setsv(val, *++MARK);
2709         else if (PL_dowarn)
2710             warn("Odd number of elements in hash assignment");
2711         (void)hv_store_ent(hv,key,val,0);
2712     }
2713     SP = ORIGMARK;
2714     XPUSHs((SV*)hv);
2715     RETURN;
2716 }
2717
2718 PP(pp_splice)
2719 {
2720     djSP; dMARK; dORIGMARK;
2721     register AV *ary = (AV*)*++MARK;
2722     register SV **src;
2723     register SV **dst;
2724     register I32 i;
2725     register I32 offset;
2726     register I32 length;
2727     I32 newlen;
2728     I32 after;
2729     I32 diff;
2730     SV **tmparyval = 0;
2731     MAGIC *mg;
2732
2733     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2734         *MARK-- = mg->mg_obj;
2735         PUSHMARK(MARK);
2736         PUTBACK;
2737         ENTER;
2738         perl_call_method("SPLICE",GIMME_V);
2739         LEAVE;
2740         SPAGAIN;
2741         RETURN;
2742     }
2743
2744     SP++;
2745
2746     if (++MARK < SP) {
2747         offset = i = SvIVx(*MARK);
2748         if (offset < 0)
2749             offset += AvFILLp(ary) + 1;
2750         else
2751             offset -= PL_curcop->cop_arybase;
2752         if (offset < 0)
2753             DIE(no_aelem, i);
2754         if (++MARK < SP) {
2755             length = SvIVx(*MARK++);
2756             if (length < 0) {
2757                 length += AvFILLp(ary) - offset + 1;
2758                 if (length < 0)
2759                     length = 0;
2760             }
2761         }
2762         else
2763             length = AvMAX(ary) + 1;            /* close enough to infinity */
2764     }
2765     else {
2766         offset = 0;
2767         length = AvMAX(ary) + 1;
2768     }
2769     if (offset > AvFILLp(ary) + 1)
2770         offset = AvFILLp(ary) + 1;
2771     after = AvFILLp(ary) + 1 - (offset + length);
2772     if (after < 0) {                            /* not that much array */
2773         length += after;                        /* offset+length now in array */
2774         after = 0;
2775         if (!AvALLOC(ary))
2776             av_extend(ary, 0);
2777     }
2778
2779     /* At this point, MARK .. SP-1 is our new LIST */
2780
2781     newlen = SP - MARK;
2782     diff = newlen - length;
2783     if (newlen && !AvREAL(ary)) {
2784         if (AvREIFY(ary))
2785             av_reify(ary);
2786         else
2787             assert(AvREAL(ary));                /* would leak, so croak */
2788     }
2789
2790     if (diff < 0) {                             /* shrinking the area */
2791         if (newlen) {
2792             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2793             Copy(MARK, tmparyval, newlen, SV*);
2794         }
2795
2796         MARK = ORIGMARK + 1;
2797         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2798             MEXTEND(MARK, length);
2799             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2800             if (AvREAL(ary)) {
2801                 EXTEND_MORTAL(length);
2802                 for (i = length, dst = MARK; i; i--) {
2803                     sv_2mortal(*dst);   /* free them eventualy */
2804                     dst++;
2805                 }
2806             }
2807             MARK += length - 1;
2808         }
2809         else {
2810             *MARK = AvARRAY(ary)[offset+length-1];
2811             if (AvREAL(ary)) {
2812                 sv_2mortal(*MARK);
2813                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2814                     SvREFCNT_dec(*dst++);       /* free them now */
2815             }
2816         }
2817         AvFILLp(ary) += diff;
2818
2819         /* pull up or down? */
2820
2821         if (offset < after) {                   /* easier to pull up */
2822             if (offset) {                       /* esp. if nothing to pull */
2823                 src = &AvARRAY(ary)[offset-1];
2824                 dst = src - diff;               /* diff is negative */
2825                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2826                     *dst-- = *src--;
2827             }
2828             dst = AvARRAY(ary);
2829             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2830             AvMAX(ary) += diff;
2831         }
2832         else {
2833             if (after) {                        /* anything to pull down? */
2834                 src = AvARRAY(ary) + offset + length;
2835                 dst = src + diff;               /* diff is negative */
2836                 Move(src, dst, after, SV*);
2837             }
2838             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2839                                                 /* avoid later double free */
2840         }
2841         i = -diff;
2842         while (i)
2843             dst[--i] = &PL_sv_undef;
2844
2845         if (newlen) {
2846             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2847               newlen; newlen--) {
2848                 *dst = NEWSV(46, 0);
2849                 sv_setsv(*dst++, *src++);
2850             }
2851             Safefree(tmparyval);
2852         }
2853     }
2854     else {                                      /* no, expanding (or same) */
2855         if (length) {
2856             New(452, tmparyval, length, SV*);   /* so remember deletion */
2857             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2858         }
2859
2860         if (diff > 0) {                         /* expanding */
2861
2862             /* push up or down? */
2863
2864             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2865                 if (offset) {
2866                     src = AvARRAY(ary);
2867                     dst = src - diff;
2868                     Move(src, dst, offset, SV*);
2869                 }
2870                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2871                 AvMAX(ary) += diff;
2872                 AvFILLp(ary) += diff;
2873             }
2874             else {
2875                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2876                     av_extend(ary, AvFILLp(ary) + diff);
2877                 AvFILLp(ary) += diff;
2878
2879                 if (after) {
2880                     dst = AvARRAY(ary) + AvFILLp(ary);
2881                     src = dst - diff;
2882                     for (i = after; i; i--) {
2883                         *dst-- = *src--;
2884                     }
2885                 }
2886             }
2887         }
2888
2889         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2890             *dst = NEWSV(46, 0);
2891             sv_setsv(*dst++, *src++);
2892         }
2893         MARK = ORIGMARK + 1;
2894         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2895             if (length) {
2896                 Copy(tmparyval, MARK, length, SV*);
2897                 if (AvREAL(ary)) {
2898                     EXTEND_MORTAL(length);
2899                     for (i = length, dst = MARK; i; i--) {
2900                         sv_2mortal(*dst);       /* free them eventualy */
2901                         dst++;
2902                     }
2903                 }
2904                 Safefree(tmparyval);
2905             }
2906             MARK += length - 1;
2907         }
2908         else if (length--) {
2909             *MARK = tmparyval[length];
2910             if (AvREAL(ary)) {
2911                 sv_2mortal(*MARK);
2912                 while (length-- > 0)
2913                     SvREFCNT_dec(tmparyval[length]);
2914             }
2915             Safefree(tmparyval);
2916         }
2917         else
2918             *MARK = &PL_sv_undef;
2919     }
2920     SP = MARK;
2921     RETURN;
2922 }
2923
2924 PP(pp_push)
2925 {
2926     djSP; dMARK; dORIGMARK; dTARGET;
2927     register AV *ary = (AV*)*++MARK;
2928     register SV *sv = &PL_sv_undef;
2929     MAGIC *mg;
2930
2931     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2932         *MARK-- = mg->mg_obj;
2933         PUSHMARK(MARK);
2934         PUTBACK;
2935         ENTER;
2936         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2937         LEAVE;
2938         SPAGAIN;
2939     }
2940     else {
2941         /* Why no pre-extend of ary here ? */
2942         for (++MARK; MARK <= SP; MARK++) {
2943             sv = NEWSV(51, 0);
2944             if (*MARK)
2945                 sv_setsv(sv, *MARK);
2946             av_push(ary, sv);
2947         }
2948     }
2949     SP = ORIGMARK;
2950     PUSHi( AvFILL(ary) + 1 );
2951     RETURN;
2952 }
2953
2954 PP(pp_pop)
2955 {
2956     djSP;
2957     AV *av = (AV*)POPs;
2958     SV *sv = av_pop(av);
2959     if (AvREAL(av))
2960         (void)sv_2mortal(sv);
2961     PUSHs(sv);
2962     RETURN;
2963 }
2964
2965 PP(pp_shift)
2966 {
2967     djSP;
2968     AV *av = (AV*)POPs;
2969     SV *sv = av_shift(av);
2970     EXTEND(SP, 1);
2971     if (!sv)
2972         RETPUSHUNDEF;
2973     if (AvREAL(av))
2974         (void)sv_2mortal(sv);
2975     PUSHs(sv);
2976     RETURN;
2977 }
2978
2979 PP(pp_unshift)
2980 {
2981     djSP; dMARK; dORIGMARK; dTARGET;
2982     register AV *ary = (AV*)*++MARK;
2983     register SV *sv;
2984     register I32 i = 0;
2985     MAGIC *mg;
2986
2987     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2988         *MARK-- = mg->mg_obj;
2989         PUSHMARK(MARK);
2990         PUTBACK;
2991         ENTER;
2992         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2993         LEAVE;
2994         SPAGAIN;
2995     }
2996     else {
2997         av_unshift(ary, SP - MARK);
2998         while (MARK < SP) {
2999             sv = NEWSV(27, 0);
3000             sv_setsv(sv, *++MARK);
3001             (void)av_store(ary, i++, sv);
3002         }
3003     }
3004     SP = ORIGMARK;
3005     PUSHi( AvFILL(ary) + 1 );
3006     RETURN;
3007 }
3008
3009 PP(pp_reverse)
3010 {
3011     djSP; dMARK;
3012     register SV *tmp;
3013     SV **oldsp = SP;
3014
3015     if (GIMME == G_ARRAY) {
3016         MARK++;
3017         while (MARK < SP) {
3018             tmp = *MARK;
3019             *MARK++ = *SP;
3020             *SP-- = tmp;
3021         }
3022         SP = oldsp;
3023     }
3024     else {
3025         register char *up;
3026         register char *down;
3027         register I32 tmp;
3028         dTARGET;
3029         STRLEN len;
3030
3031         if (SP - MARK > 1)
3032             do_join(TARG, &PL_sv_no, MARK, SP);
3033         else
3034             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3035         up = SvPV_force(TARG, len);
3036         if (len > 1) {
3037             if (IN_UTF8) {      /* first reverse each character */
3038                 unsigned char* s = SvPVX(TARG);
3039                 unsigned char* send = s + len;
3040                 while (s < send) {
3041                     if (*s < 0x80) {
3042                         s++;
3043                         continue;
3044                     }
3045                     else {
3046                         up = s;
3047                         s += UTF8SKIP(s);
3048                         down = s - 1;
3049                         if (s > send || !((*down & 0xc0) == 0x80)) {
3050                             warn("Malformed UTF-8 character");
3051                             break;
3052                         }
3053                         while (down > up) {
3054                             tmp = *up;
3055                             *up++ = *down;
3056                             *down-- = tmp;
3057                         }
3058                     }
3059                 }
3060                 up = SvPVX(TARG);
3061             }
3062             down = SvPVX(TARG) + len - 1;
3063             while (down > up) {
3064                 tmp = *up;
3065                 *up++ = *down;
3066                 *down-- = tmp;
3067             }
3068             (void)SvPOK_only(TARG);
3069         }
3070         SP = MARK + 1;
3071         SETTARG;
3072     }
3073     RETURN;
3074 }
3075
3076 STATIC SV      *
3077 mul128(SV *sv, U8 m)
3078 {
3079   STRLEN          len;
3080   char           *s = SvPV(sv, len);
3081   char           *t;
3082   U32             i = 0;
3083
3084   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3085     SV             *tmpNew = newSVpv("0000000000", 10);
3086
3087     sv_catsv(tmpNew, sv);
3088     SvREFCNT_dec(sv);           /* free old sv */
3089     sv = tmpNew;
3090     s = SvPV(sv, len);
3091   }
3092   t = s + len - 1;
3093   while (!*t)                   /* trailing '\0'? */
3094     t--;
3095   while (t > s) {
3096     i = ((*t - '0') << 7) + m;
3097     *(t--) = '0' + (i % 10);
3098     m = i / 10;
3099   }
3100   return (sv);
3101 }
3102
3103 /* Explosives and implosives. */
3104
3105 static const char uuemap[] =
3106     "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3107 static char uudmap[256];        /* Initialised on first use */
3108 #if 'I' == 73 && 'J' == 74
3109 /* On an ASCII/ISO kind of system */
3110 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3111 #else
3112 /*
3113   Some other sort of character set - use memchr() so we don't match
3114   the null byte.
3115  */
3116 #define ISUUCHAR(ch)    (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3117 #endif
3118
3119 PP(pp_unpack)
3120 {
3121     djSP;
3122     dPOPPOPssrl;
3123     SV **oldsp = SP;
3124     I32 gimme = GIMME_V;
3125     SV *sv;
3126     STRLEN llen;
3127     STRLEN rlen;
3128     register char *pat = SvPV(left, llen);
3129     register char *s = SvPV(right, rlen);
3130     char *strend = s + rlen;
3131     char *strbeg = s;
3132     register char *patend = pat + llen;
3133     I32 datumtype;
3134     register I32 len;
3135     register I32 bits;
3136
3137     /* These must not be in registers: */
3138     I16 ashort;
3139     int aint;
3140     I32 along;
3141 #ifdef HAS_QUAD
3142     Quad_t aquad;
3143 #endif
3144     U16 aushort;
3145     unsigned int auint;
3146     U32 aulong;
3147 #ifdef HAS_QUAD
3148     unsigned Quad_t auquad;
3149 #endif
3150     char *aptr;
3151     float afloat;
3152     double adouble;
3153     I32 checksum = 0;
3154     register U32 culong;
3155     double cdouble;
3156     static char* bitcount = 0;
3157     int commas = 0;
3158
3159     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3160         /*SUPPRESS 530*/
3161         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3162         if (strchr("aAbBhHP", *patend) || *pat == '%') {
3163             patend++;
3164             while (isDIGIT(*patend) || *patend == '*')
3165                 patend++;
3166         }
3167         else
3168             patend++;
3169     }
3170     while (pat < patend) {
3171       reparse:
3172         datumtype = *pat++ & 0xFF;
3173         if (isSPACE(datumtype))
3174             continue;
3175         if (pat >= patend)
3176             len = 1;
3177         else if (*pat == '*') {
3178             len = strend - strbeg;      /* long enough */
3179             pat++;
3180         }
3181         else if (isDIGIT(*pat)) {
3182             len = *pat++ - '0';
3183             while (isDIGIT(*pat))
3184                 len = (len * 10) + (*pat++ - '0');
3185         }
3186         else
3187             len = (datumtype != '@');
3188         switch(datumtype) {
3189         default:
3190             croak("Invalid type in unpack: '%c'", (int)datumtype);
3191         case ',': /* grandfather in commas but with a warning */
3192             if (commas++ == 0 && PL_dowarn)
3193                 warn("Invalid type in unpack: '%c'", (int)datumtype);
3194             break;
3195         case '%':
3196             if (len == 1 && pat[-1] != '1')
3197                 len = 16;
3198             checksum = len;
3199             culong = 0;
3200             cdouble = 0;
3201             if (pat < patend)
3202                 goto reparse;
3203             break;
3204         case '@':
3205             if (len > strend - strbeg)
3206                 DIE("@ outside of string");
3207             s = strbeg + len;
3208             break;
3209         case 'X':
3210             if (len > s - strbeg)
3211                 DIE("X outside of string");
3212             s -= len;
3213             break;
3214         case 'x':
3215             if (len > strend - s)
3216                 DIE("x outside of string");
3217             s += len;
3218             break;
3219         case 'A':
3220         case 'a':
3221             if (len > strend - s)
3222                 len = strend - s;
3223             if (checksum)
3224                 goto uchar_checksum;
3225             sv = NEWSV(35, len);
3226             sv_setpvn(sv, s, len);
3227             s += len;
3228             if (datumtype == 'A') {
3229                 aptr = s;       /* borrow register */
3230                 s = SvPVX(sv) + len - 1;
3231                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3232                     s--;
3233                 *++s = '\0';
3234                 SvCUR_set(sv, s - SvPVX(sv));
3235                 s = aptr;       /* unborrow register */
3236             }
3237             XPUSHs(sv_2mortal(sv));
3238             break;
3239         case 'B':
3240         case 'b':
3241             if (pat[-1] == '*' || len > (strend - s) * 8)
3242                 len = (strend - s) * 8;
3243             if (checksum) {
3244                 if (!bitcount) {
3245                     Newz(601, bitcount, 256, char);
3246                     for (bits = 1; bits < 256; bits++) {
3247                         if (bits & 1)   bitcount[bits]++;
3248                         if (bits & 2)   bitcount[bits]++;
3249                         if (bits & 4)   bitcount[bits]++;
3250                         if (bits & 8)   bitcount[bits]++;
3251                         if (bits & 16)  bitcount[bits]++;
3252                         if (bits & 32)  bitcount[bits]++;
3253                         if (bits & 64)  bitcount[bits]++;
3254                         if (bits & 128) bitcount[bits]++;
3255                     }
3256                 }
3257                 while (len >= 8) {
3258                     culong += bitcount[*(unsigned char*)s++];
3259                     len -= 8;
3260                 }
3261                 if (len) {
3262                     bits = *s;
3263                     if (datumtype == 'b') {
3264                         while (len-- > 0) {
3265                             if (bits & 1) culong++;
3266                             bits >>= 1;
3267                         }
3268                     }
3269                     else {
3270                         while (len-- > 0) {
3271                             if (bits & 128) culong++;
3272                             bits <<= 1;
3273                         }
3274                     }
3275                 }
3276                 break;
3277             }
3278             sv = NEWSV(35, len + 1);
3279             SvCUR_set(sv, len);
3280             SvPOK_on(sv);
3281             aptr = pat;                 /* borrow register */
3282             pat = SvPVX(sv);
3283             if (datumtype == 'b') {
3284                 aint = len;
3285                 for (len = 0; len < aint; len++) {
3286                     if (len & 7)                /*SUPPRESS 595*/
3287                         bits >>= 1;
3288                     else
3289                         bits = *s++;
3290                     *pat++ = '0' + (bits & 1);
3291                 }
3292             }
3293             else {
3294                 aint = len;
3295                 for (len = 0; len < aint; len++) {
3296                     if (len & 7)
3297                         bits <<= 1;
3298                     else
3299                         bits = *s++;
3300                     *pat++ = '0' + ((bits & 128) != 0);
3301                 }
3302             }
3303             *pat = '\0';
3304             pat = aptr;                 /* unborrow register */
3305             XPUSHs(sv_2mortal(sv));
3306             break;
3307         case 'H':
3308         case 'h':
3309             if (pat[-1] == '*' || len > (strend - s) * 2)
3310                 len = (strend - s) * 2;
3311             sv = NEWSV(35, len + 1);
3312             SvCUR_set(sv, len);
3313             SvPOK_on(sv);
3314             aptr = pat;                 /* borrow register */
3315             pat = SvPVX(sv);
3316             if (datumtype == 'h') {
3317                 aint = len;
3318                 for (len = 0; len < aint; len++) {
3319                     if (len & 1)
3320                         bits >>= 4;
3321                     else
3322                         bits = *s++;
3323                     *pat++ = PL_hexdigit[bits & 15];
3324                 }
3325             }
3326             else {
3327                 aint = len;
3328                 for (len = 0; len < aint; len++) {
3329                     if (len & 1)
3330                         bits <<= 4;
3331                     else
3332                         bits = *s++;
3333                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3334                 }
3335             }
3336             *pat = '\0';
3337             pat = aptr;                 /* unborrow register */
3338             XPUSHs(sv_2mortal(sv));
3339             break;
3340         case 'c':
3341             if (len > strend - s)
3342                 len = strend - s;
3343             if (checksum) {
3344                 while (len-- > 0) {
3345                     aint = *s++;
3346                     if (aint >= 128)    /* fake up signed chars */
3347                         aint -= 256;
3348                     culong += aint;
3349                 }
3350             }
3351             else {
3352                 EXTEND(SP, len);
3353                 EXTEND_MORTAL(len);
3354                 while (len-- > 0) {
3355                     aint = *s++;
3356                     if (aint >= 128)    /* fake up signed chars */
3357                         aint -= 256;
3358                     sv = NEWSV(36, 0);
3359                     sv_setiv(sv, (IV)aint);
3360                     PUSHs(sv_2mortal(sv));
3361                 }
3362             }
3363             break;
3364         case 'C':
3365             if (len > strend - s)
3366                 len = strend - s;
3367             if (checksum) {
3368               uchar_checksum:
3369                 while (len-- > 0) {
3370                     auint = *s++ & 255;
3371                     culong += auint;
3372                 }
3373             }
3374             else {
3375                 EXTEND(SP, len);
3376                 EXTEND_MORTAL(len);
3377                 while (len-- > 0) {
3378                     auint = *s++ & 255;
3379                     sv = NEWSV(37, 0);
3380                     sv_setiv(sv, (IV)auint);
3381                     PUSHs(sv_2mortal(sv));
3382                 }
3383             }
3384             break;
3385         case 'U':
3386             if (len > strend - s)
3387                 len = strend - s;
3388             if (checksum) {
3389                 while (len-- > 0 && s < strend) {
3390                     auint = utf8_to_uv(s, &along);
3391                     s += along;
3392                     culong += auint;
3393                 }
3394             }
3395             else {
3396                 EXTEND(SP, len);
3397                 EXTEND_MORTAL(len);
3398                 while (len-- > 0 && s < strend) {
3399                     auint = utf8_to_uv(s, &along);
3400                     s += along;
3401                     sv = NEWSV(37, 0);
3402                     sv_setiv(sv, (IV)auint);
3403                     PUSHs(sv_2mortal(sv));
3404                 }
3405             }
3406             break;
3407         case 's':
3408             along = (strend - s) / SIZE16;
3409             if (len > along)
3410                 len = along;
3411             if (checksum) {
3412                 while (len-- > 0) {
3413                     COPY16(s, &ashort);
3414                     s += SIZE16;
3415                     culong += ashort;
3416                 }
3417             }
3418             else {
3419                 EXTEND(SP, len);
3420                 EXTEND_MORTAL(len);
3421                 while (len-- > 0) {
3422                     COPY16(s, &ashort);
3423                     s += SIZE16;
3424                     sv = NEWSV(38, 0);
3425                     sv_setiv(sv, (IV)ashort);
3426                     PUSHs(sv_2mortal(sv));
3427                 }
3428             }
3429             break;
3430         case 'v':
3431         case 'n':
3432         case 'S':
3433             along = (strend - s) / SIZE16;
3434             if (len > along)
3435                 len = along;
3436             if (checksum) {
3437                 while (len-- > 0) {
3438                     COPY16(s, &aushort);
3439                     s += SIZE16;
3440 #ifdef HAS_NTOHS
3441                     if (datumtype == 'n')
3442                         aushort = PerlSock_ntohs(aushort);
3443 #endif
3444 #ifdef HAS_VTOHS
3445                     if (datumtype == 'v')
3446                         aushort = vtohs(aushort);
3447 #endif
3448                     culong += aushort;
3449                 }
3450             }
3451             else {
3452                 EXTEND(SP, len);
3453                 EXTEND_MORTAL(len);
3454                 while (len-- > 0) {
3455                     COPY16(s, &aushort);
3456                     s += SIZE16;
3457                     sv = NEWSV(39, 0);
3458 #ifdef HAS_NTOHS
3459                     if (datumtype == 'n')
3460                         aushort = PerlSock_ntohs(aushort);
3461 #endif
3462 #ifdef HAS_VTOHS
3463                     if (datumtype == 'v')
3464                         aushort = vtohs(aushort);
3465 #endif
3466                     sv_setiv(sv, (IV)aushort);
3467                     PUSHs(sv_2mortal(sv));
3468                 }
3469             }
3470             break;
3471         case 'i':
3472             along = (strend - s) / sizeof(int);
3473             if (len > along)
3474                 len = along;
3475             if (checksum) {
3476                 while (len-- > 0) {
3477                     Copy(s, &aint, 1, int);
3478                     s += sizeof(int);
3479                     if (checksum > 32)
3480                         cdouble += (double)aint;
3481                     else
3482                         culong += aint;
3483                 }
3484             }
3485             else {
3486                 EXTEND(SP, len);
3487                 EXTEND_MORTAL(len);
3488                 while (len-- > 0) {
3489                     Copy(s, &aint, 1, int);
3490                     s += sizeof(int);
3491                     sv = NEWSV(40, 0);
3492 #ifdef __osf__
3493                     /* Without the dummy below unpack("i", pack("i",-1))
3494                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3495                      * cc with optimization turned on */
3496                     (aint) ?
3497                         sv_setiv(sv, (IV)aint) :
3498 #endif
3499                     sv_setiv(sv, (IV)aint);
3500                     PUSHs(sv_2mortal(sv));
3501                 }
3502             }
3503             break;
3504         case 'I':
3505             along = (strend - s) / sizeof(unsigned int);
3506             if (len > along)
3507                 len = along;
3508             if (checksum) {
3509                 while (len-- > 0) {
3510                     Copy(s, &auint, 1, unsigned int);
3511                     s += sizeof(unsigned int);
3512                     if (checksum > 32)
3513                         cdouble += (double)auint;
3514                     else
3515                         culong += auint;
3516                 }
3517             }
3518             else {
3519                 EXTEND(SP, len);
3520                 EXTEND_MORTAL(len);
3521                 while (len-- > 0) {
3522                     Copy(s, &auint, 1, unsigned int);
3523                     s += sizeof(unsigned int);
3524                     sv = NEWSV(41, 0);
3525                     sv_setuv(sv, (UV)auint);
3526                     PUSHs(sv_2mortal(sv));
3527                 }
3528             }
3529             break;
3530         case 'l':
3531             along = (strend - s) / SIZE32;
3532             if (len > along)
3533                 len = along;
3534             if (checksum) {
3535                 while (len-- > 0) {
3536                     COPY32(s, &along);
3537                     s += SIZE32;
3538                     if (checksum > 32)
3539                         cdouble += (double)along;
3540                     else
3541                         culong += along;
3542                 }
3543             }
3544             else {
3545                 EXTEND(SP, len);
3546                 EXTEND_MORTAL(len);
3547                 while (len-- > 0) {
3548                     COPY32(s, &along);
3549                     s += SIZE32;
3550                     sv = NEWSV(42, 0);
3551                     sv_setiv(sv, (IV)along);
3552                     PUSHs(sv_2mortal(sv));
3553                 }
3554             }
3555             break;
3556         case 'V':
3557         case 'N':
3558         case 'L':
3559             along = (strend - s) / SIZE32;
3560             if (len > along)
3561                 len = along;
3562             if (checksum) {
3563                 while (len-- > 0) {
3564                     COPY32(s, &aulong);
3565                     s += SIZE32;
3566 #ifdef HAS_NTOHL
3567                     if (datumtype == 'N')
3568                         aulong = PerlSock_ntohl(aulong);
3569 #endif
3570 #ifdef HAS_VTOHL
3571                     if (datumtype == 'V')
3572                         aulong = vtohl(aulong);
3573 #endif
3574                     if (checksum > 32)
3575                         cdouble += (double)aulong;
3576                     else
3577                         culong += aulong;
3578                 }
3579             }
3580             else {
3581                 EXTEND(SP, len);
3582                 EXTEND_MORTAL(len);
3583                 while (len-- > 0) {
3584                     COPY32(s, &aulong);
3585                     s += SIZE32;
3586 #ifdef HAS_NTOHL
3587                     if (datumtype == 'N')
3588                         aulong = PerlSock_ntohl(aulong);
3589 #endif
3590 #ifdef HAS_VTOHL
3591                     if (datumtype == 'V')
3592                         aulong = vtohl(aulong);
3593 #endif
3594                     sv = NEWSV(43, 0);
3595                     sv_setuv(sv, (UV)aulong);
3596                     PUSHs(sv_2mortal(sv));
3597                 }
3598             }
3599             break;
3600         case 'p':
3601             along = (strend - s) / sizeof(char*);
3602             if (len > along)
3603                 len = along;
3604             EXTEND(SP, len);
3605             EXTEND_MORTAL(len);
3606             while (len-- > 0) {
3607                 if (sizeof(char*) > strend - s)
3608                     break;
3609                 else {
3610                     Copy(s, &aptr, 1, char*);
3611                     s += sizeof(char*);
3612                 }
3613                 sv = NEWSV(44, 0);
3614                 if (aptr)
3615                     sv_setpv(sv, aptr);
3616                 PUSHs(sv_2mortal(sv));
3617             }
3618             break;
3619         case 'w':
3620             EXTEND(SP, len);
3621             EXTEND_MORTAL(len);
3622             {
3623                 UV auv = 0;
3624                 U32 bytes = 0;
3625
3626                 while ((len > 0) && (s < strend)) {
3627                     auv = (auv << 7) | (*s & 0x7f);
3628                     if (!(*s++ & 0x80)) {
3629                         bytes = 0;
3630                         sv = NEWSV(40, 0);
3631                         sv_setuv(sv, auv);
3632                         PUSHs(sv_2mortal(sv));
3633                         len--;
3634                         auv = 0;
3635                     }
3636                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3637                         char *t;
3638
3639                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3640                         while (s < strend) {
3641                             sv = mul128(sv, *s & 0x7f);
3642                             if (!(*s++ & 0x80)) {
3643                                 bytes = 0;
3644                                 break;
3645                             }
3646                         }
3647                         t = SvPV(sv, PL_na);
3648                         while (*t == '0')
3649                             t++;
3650                         sv_chop(sv, t);
3651                         PUSHs(sv_2mortal(sv));
3652                         len--;
3653                         auv = 0;
3654                     }
3655                 }
3656                 if ((s >= strend) && bytes)
3657                     croak("Unterminated compressed integer");
3658             }
3659             break;
3660         case 'P':
3661             EXTEND(SP, 1);
3662             if (sizeof(char*) > strend - s)
3663                 break;
3664             else {
3665                 Copy(s, &aptr, 1, char*);
3666                 s += sizeof(char*);
3667             }
3668             sv = NEWSV(44, 0);
3669             if (aptr)
3670                 sv_setpvn(sv, aptr, len);
3671             PUSHs(sv_2mortal(sv));
3672             break;
3673 #ifdef HAS_QUAD
3674         case 'q':
3675             along = (strend - s) / sizeof(Quad_t);
3676             if (len > along)
3677                 len = along;
3678             EXTEND(SP, len);
3679             EXTEND_MORTAL(len);
3680             while (len-- > 0) {
3681                 if (s + sizeof(Quad_t) > strend)
3682                     aquad = 0;
3683                 else {
3684                     Copy(s, &aquad, 1, Quad_t);
3685                     s += sizeof(Quad_t);
3686                 }
3687                 sv = NEWSV(42, 0);
3688                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3689                     sv_setiv(sv, (IV)aquad);
3690                 else
3691                     sv_setnv(sv, (double)aquad);
3692                 PUSHs(sv_2mortal(sv));
3693             }
3694             break;
3695         case 'Q':
3696             along = (strend - s) / sizeof(Quad_t);
3697             if (len > along)
3698                 len = along;
3699             EXTEND(SP, len);
3700             EXTEND_MORTAL(len);
3701             while (len-- > 0) {
3702                 if (s + sizeof(unsigned Quad_t) > strend)
3703                     auquad = 0;
3704                 else {
3705                     Copy(s, &auquad, 1, unsigned Quad_t);
3706                     s += sizeof(unsigned Quad_t);
3707                 }
3708                 sv = NEWSV(43, 0);
3709                 if (auquad <= UV_MAX)
3710                     sv_setuv(sv, (UV)auquad);
3711                 else
3712                     sv_setnv(sv, (double)auquad);
3713                 PUSHs(sv_2mortal(sv));
3714             }
3715             break;
3716 #endif
3717         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3718         case 'f':
3719         case 'F':
3720             along = (strend - s) / sizeof(float);
3721             if (len > along)
3722                 len = along;
3723             if (checksum) {
3724                 while (len-- > 0) {
3725                     Copy(s, &afloat, 1, float);
3726                     s += sizeof(float);
3727                     cdouble += afloat;
3728                 }
3729             }
3730             else {
3731                 EXTEND(SP, len);
3732                 EXTEND_MORTAL(len);
3733                 while (len-- > 0) {
3734                     Copy(s, &afloat, 1, float);
3735                     s += sizeof(float);
3736                     sv = NEWSV(47, 0);
3737                     sv_setnv(sv, (double)afloat);
3738                     PUSHs(sv_2mortal(sv));
3739                 }
3740             }
3741             break;
3742         case 'd':
3743         case 'D':
3744             along = (strend - s) / sizeof(double);
3745             if (len > along)
3746                 len = along;
3747             if (checksum) {
3748                 while (len-- > 0) {
3749                     Copy(s, &adouble, 1, double);
3750                     s += sizeof(double);
3751                     cdouble += adouble;
3752                 }
3753             }
3754             else {
3755                 EXTEND(SP, len);
3756                 EXTEND_MORTAL(len);
3757                 while (len-- > 0) {
3758                     Copy(s, &adouble, 1, double);
3759                     s += sizeof(double);
3760                     sv = NEWSV(48, 0);
3761                     sv_setnv(sv, (double)adouble);
3762                     PUSHs(sv_2mortal(sv));
3763                 }
3764             }
3765             break;
3766         case 'u':
3767             /* MKS:
3768              * Initialise the decode mapping.  By using a table driven
3769              * algorithm, the code will be character-set independent
3770              * (and just as fast as doing character arithmetic)
3771              */
3772             if (uudmap['M'] == 0) {
3773                 int i;
3774
3775                 for (i = 0; i < sizeof(uuemap); i += 1)
3776                     uudmap[uuemap[i]] = i;
3777                 /*
3778                  * Because ' ' and '`' map to the same value,
3779                  * we need to decode them both the same.
3780                  */
3781                 uudmap[' '] = 0;
3782             }
3783
3784             along = (strend - s) * 3 / 4;
3785             sv = NEWSV(42, along);
3786             if (along)
3787                 SvPOK_on(sv);
3788             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3789                 I32 a, b, c, d;
3790                 char hunk[4];
3791
3792                 hunk[3] = '\0';
3793                 len = (*s++ - ' ') & 077;
3794                 while (len > 0) {
3795                     if (s < strend && ISUUCHAR(*s))
3796                         a = uudmap[*s++] & 077;
3797                     else
3798                         a = 0;
3799                     if (s < strend && ISUUCHAR(*s))
3800                         b = uudmap[*s++] & 077;
3801                     else
3802                         b = 0;
3803                     if (s < strend && ISUUCHAR(*s))
3804                         c = uudmap[*s++] & 077;
3805                     else
3806                         c = 0;
3807                     if (s < strend && ISUUCHAR(*s))
3808                         d = uudmap[*s++] & 077;
3809                     else
3810                         d = 0;
3811                     hunk[0] = (a << 2) | (b >> 4);
3812                     hunk[1] = (b << 4) | (c >> 2);
3813                     hunk[2] = (c << 6) | d;
3814                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3815                     len -= 3;
3816                 }
3817                 if (*s == '\n')
3818                     s++;
3819                 else if (s[1] == '\n')          /* possible checksum byte */
3820                     s += 2;
3821             }
3822             XPUSHs(sv_2mortal(sv));
3823             break;
3824         }
3825         if (checksum) {
3826             sv = NEWSV(42, 0);
3827             if (strchr("fFdD", datumtype) ||
3828               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3829                 double trouble;
3830
3831                 adouble = 1.0;
3832                 while (checksum >= 16) {
3833                     checksum -= 16;
3834                     adouble *= 65536.0;
3835                 }
3836                 while (checksum >= 4) {
3837                     checksum -= 4;
3838                     adouble *= 16.0;
3839                 }
3840                 while (checksum--)
3841                     adouble *= 2.0;
3842                 along = (1 << checksum) - 1;
3843                 while (cdouble < 0.0)
3844                     cdouble += adouble;
3845                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3846                 sv_setnv(sv, cdouble);
3847             }
3848             else {
3849                 if (checksum < 32) {
3850                     aulong = (1 << checksum) - 1;
3851                     culong &= aulong;
3852                 }
3853                 sv_setuv(sv, (UV)culong);
3854             }
3855             XPUSHs(sv_2mortal(sv));
3856             checksum = 0;
3857         }
3858     }
3859     if (SP == oldsp && gimme == G_SCALAR)
3860         PUSHs(&PL_sv_undef);
3861     RETURN;
3862 }
3863
3864 STATIC void
3865 doencodes(register SV *sv, register char *s, register I32 len)
3866 {
3867     char hunk[5];
3868
3869     *hunk = uuemap[len];
3870     sv_catpvn(sv, hunk, 1);
3871     hunk[4] = '\0';
3872     while (len > 2) {
3873         hunk[0] = uuemap[(077 & (*s >> 2))];
3874         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3875         hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3876         hunk[3] = uuemap[(077 & (s[2] & 077))];
3877         sv_catpvn(sv, hunk, 4);
3878         s += 3;
3879         len -= 3;
3880     }
3881     if (len > 0) {
3882         char r = (len > 1 ? s[1] : '\0');
3883         hunk[0] = uuemap[(077 & (*s >> 2))];
3884         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3885         hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3886         hunk[3] = uuemap[0];
3887         sv_catpvn(sv, hunk, 4);
3888     }
3889     sv_catpvn(sv, "\n", 1);
3890 }
3891
3892 STATIC SV      *
3893 is_an_int(char *s, STRLEN l)
3894 {
3895   SV             *result = newSVpv("", l);
3896   char           *result_c = SvPV(result, PL_na);       /* convenience */
3897   char           *out = result_c;
3898   bool            skip = 1;
3899   bool            ignore = 0;
3900
3901   while (*s) {
3902     switch (*s) {
3903     case ' ':
3904       break;
3905     case '+':
3906       if (!skip) {
3907         SvREFCNT_dec(result);
3908         return (NULL);
3909       }
3910       break;
3911     case '0':
3912     case '1':
3913     case '2':
3914     case '3':
3915     case '4':
3916     case '5':
3917     case '6':
3918     case '7':
3919     case '8':
3920     case '9':
3921       skip = 0;
3922       if (!ignore) {
3923         *(out++) = *s;
3924       }
3925       break;
3926     case '.':
3927       ignore = 1;
3928       break;
3929     default:
3930       SvREFCNT_dec(result);
3931       return (NULL);
3932     }
3933     s++;
3934   }
3935   *(out++) = '\0';
3936   SvCUR_set(result, out - result_c);
3937   return (result);
3938 }
3939
3940 STATIC int
3941 div128(SV *pnum, bool *done)
3942                                             /* must be '\0' terminated */
3943
3944 {
3945   STRLEN          len;
3946   char           *s = SvPV(pnum, len);
3947   int             m = 0;
3948   int             r = 0;
3949   char           *t = s;
3950
3951   *done = 1;
3952   while (*t) {
3953     int             i;
3954
3955     i = m * 10 + (*t - '0');
3956     m = i & 0x7F;
3957     r = (i >> 7);               /* r < 10 */
3958     if (r) {
3959       *done = 0;
3960     }
3961     *(t++) = '0' + r;
3962   }
3963   *(t++) = '\0';
3964   SvCUR_set(pnum, (STRLEN) (t - s));
3965   return (m);
3966 }
3967
3968
3969 PP(pp_pack)
3970 {
3971     djSP; dMARK; dORIGMARK; dTARGET;
3972     register SV *cat = TARG;
3973     register I32 items;
3974     STRLEN fromlen;
3975     register char *pat = SvPVx(*++MARK, fromlen);
3976     register char *patend = pat + fromlen;
3977     register I32 len;
3978     I32 datumtype;
3979     SV *fromstr;
3980     /*SUPPRESS 442*/
3981     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3982     static char *space10 = "          ";
3983
3984     /* These must not be in registers: */
3985     char achar;
3986     I16 ashort;
3987     int aint;
3988     unsigned int auint;
3989     I32 along;
3990     U32 aulong;
3991 #ifdef HAS_QUAD
3992     Quad_t aquad;
3993     unsigned Quad_t auquad;
3994 #endif
3995     char *aptr;
3996     float afloat;
3997     double adouble;
3998     int commas = 0;
3999
4000     items = SP - MARK;
4001     MARK++;
4002     sv_setpvn(cat, "", 0);
4003     while (pat < patend) {
4004 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4005         datumtype = *pat++ & 0xFF;
4006         if (isSPACE(datumtype))
4007             continue;
4008         if (*pat == '*') {
4009             len = strchr("@Xxu", datumtype) ? 0 : items;
4010             pat++;
4011         }
4012         else if (isDIGIT(*pat)) {
4013             len = *pat++ - '0';
4014             while (isDIGIT(*pat))
4015                 len = (len * 10) + (*pat++ - '0');
4016         }
4017         else
4018             len = 1;
4019         switch(datumtype) {
4020         default:
4021             croak("Invalid type in pack: '%c'", (int)datumtype);
4022         case ',': /* grandfather in commas but with a warning */
4023             if (commas++ == 0 && PL_dowarn)
4024                 warn("Invalid type in pack: '%c'", (int)datumtype);
4025             break;
4026         case '%':
4027             DIE("%% may only be used in unpack");
4028         case '@':
4029             len -= SvCUR(cat);
4030             if (len > 0)
4031                 goto grow;
4032             len = -len;
4033             if (len > 0)
4034                 goto shrink;
4035             break;
4036         case 'X':
4037           shrink:
4038             if (SvCUR(cat) < len)
4039                 DIE("X outside of string");
4040             SvCUR(cat) -= len;
4041             *SvEND(cat) = '\0';
4042             break;
4043         case 'x':
4044           grow:
4045             while (len >= 10) {
4046                 sv_catpvn(cat, null10, 10);
4047                 len -= 10;
4048             }
4049             sv_catpvn(cat, null10, len);
4050             break;
4051         case 'A':
4052         case 'a':
4053             fromstr = NEXTFROM;
4054             aptr = SvPV(fromstr, fromlen);
4055             if (pat[-1] == '*')
4056                 len = fromlen;
4057             if (fromlen > len)
4058                 sv_catpvn(cat, aptr, len);
4059             else {
4060                 sv_catpvn(cat, aptr, fromlen);
4061                 len -= fromlen;
4062                 if (datumtype == 'A') {
4063                     while (len >= 10) {
4064                         sv_catpvn(cat, space10, 10);
4065                         len -= 10;
4066                     }
4067                     sv_catpvn(cat, space10, len);
4068                 }
4069                 else {
4070                     while (len >= 10) {
4071                         sv_catpvn(cat, null10, 10);
4072                         len -= 10;
4073                     }
4074                     sv_catpvn(cat, null10, len);
4075                 }
4076             }
4077             break;
4078         case 'B':
4079         case 'b':
4080             {
4081                 char *savepat = pat;
4082                 I32 saveitems;
4083
4084                 fromstr = NEXTFROM;
4085                 saveitems = items;
4086                 aptr = SvPV(fromstr, fromlen);
4087                 if (pat[-1] == '*')
4088                     len = fromlen;
4089                 pat = aptr;
4090                 aint = SvCUR(cat);
4091                 SvCUR(cat) += (len+7)/8;
4092                 SvGROW(cat, SvCUR(cat) + 1);
4093                 aptr = SvPVX(cat) + aint;
4094                 if (len > fromlen)
4095                     len = fromlen;
4096                 aint = len;
4097                 items = 0;
4098                 if (datumtype == 'B') {
4099                     for (len = 0; len++ < aint;) {
4100                         items |= *pat++ & 1;
4101                         if (len & 7)
4102                             items <<= 1;
4103                         else {
4104                             *aptr++ = items & 0xff;
4105                             items = 0;
4106                         }
4107                     }
4108                 }
4109                 else {
4110                     for (len = 0; len++ < aint;) {
4111                         if (*pat++ & 1)
4112                             items |= 128;
4113                         if (len & 7)
4114                             items >>= 1;
4115                         else {
4116                             *aptr++ = items & 0xff;
4117                             items = 0;
4118                         }
4119                     }
4120                 }
4121                 if (aint & 7) {
4122                     if (datumtype == 'B')
4123                         items <<= 7 - (aint & 7);
4124                     else
4125                         items >>= 7 - (aint & 7);
4126                     *aptr++ = items & 0xff;
4127                 }
4128                 pat = SvPVX(cat) + SvCUR(cat);
4129                 while (aptr <= pat)
4130                     *aptr++ = '\0';
4131
4132                 pat = savepat;
4133                 items = saveitems;
4134             }
4135             break;
4136         case 'H':
4137         case 'h':
4138             {
4139                 char *savepat = pat;
4140                 I32 saveitems;
4141
4142                 fromstr = NEXTFROM;
4143                 saveitems = items;
4144                 aptr = SvPV(fromstr, fromlen);
4145                 if (pat[-1] == '*')
4146                     len = fromlen;
4147                 pat = aptr;
4148                 aint = SvCUR(cat);
4149                 SvCUR(cat) += (len+1)/2;
4150                 SvGROW(cat, SvCUR(cat) + 1);
4151                 aptr = SvPVX(cat) + aint;
4152                 if (len > fromlen)
4153                     len = fromlen;
4154                 aint = len;
4155                 items = 0;
4156                 if (datumtype == 'H') {
4157                     for (len = 0; len++ < aint;) {
4158                         if (isALPHA(*pat))
4159                             items |= ((*pat++ & 15) + 9) & 15;
4160                         else
4161                             items |= *pat++ & 15;
4162                         if (len & 1)
4163                             items <<= 4;
4164                         else {
4165                             *aptr++ = items & 0xff;
4166                             items = 0;
4167                         }
4168                     }
4169                 }
4170                 else {
4171                     for (len = 0; len++ < aint;) {
4172                         if (isALPHA(*pat))
4173                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4174                         else
4175                             items |= (*pat++ & 15) << 4;
4176                         if (len & 1)
4177                             items >>= 4;
4178                         else {
4179                             *aptr++ = items & 0xff;
4180                             items = 0;
4181                         }
4182                     }
4183                 }
4184                 if (aint & 1)
4185                     *aptr++ = items & 0xff;
4186                 pat = SvPVX(cat) + SvCUR(cat);
4187                 while (aptr <= pat)
4188                     *aptr++ = '\0';
4189
4190                 pat = savepat;
4191                 items = saveitems;
4192             }
4193             break;
4194         case 'C':
4195         case 'c':
4196             while (len-- > 0) {
4197                 fromstr = NEXTFROM;
4198                 aint = SvIV(fromstr);
4199                 achar = aint;
4200                 sv_catpvn(cat, &achar, sizeof(char));
4201             }
4202             break;
4203         case 'U':
4204             while (len-- > 0) {
4205                 fromstr = NEXTFROM;
4206                 auint = SvUV(fromstr);
4207                 SvGROW(cat, SvCUR(cat) + 10);
4208                 SvCUR_set(cat, uv_to_utf8(SvEND(cat), auint) - SvPVX(cat));
4209             }
4210             *SvEND(cat) = '\0';
4211             break;
4212         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4213         case 'f':
4214         case 'F':
4215             while (len-- > 0) {
4216                 fromstr = NEXTFROM;
4217                 afloat = (float)SvNV(fromstr);
4218                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4219             }
4220             break;
4221         case 'd':
4222         case 'D':
4223             while (len-- > 0) {
4224                 fromstr = NEXTFROM;
4225                 adouble = (double)SvNV(fromstr);
4226                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4227             }
4228             break;
4229         case 'n':
4230             while (len-- > 0) {
4231                 fromstr = NEXTFROM;
4232                 ashort = (I16)SvIV(fromstr);
4233 #ifdef HAS_HTONS
4234                 ashort = PerlSock_htons(ashort);
4235 #endif
4236                 CAT16(cat, &ashort);
4237             }
4238             break;
4239         case 'v':
4240             while (len-- > 0) {
4241                 fromstr = NEXTFROM;
4242                 ashort = (I16)SvIV(fromstr);
4243 #ifdef HAS_HTOVS
4244                 ashort = htovs(ashort);
4245 #endif
4246                 CAT16(cat, &ashort);
4247             }
4248             break;
4249         case 'S':
4250         case 's':
4251             while (len-- > 0) {
4252                 fromstr = NEXTFROM;
4253                 ashort = (I16)SvIV(fromstr);
4254                 CAT16(cat, &ashort);
4255             }
4256             break;
4257         case 'I':
4258             while (len-- > 0) {
4259                 fromstr = NEXTFROM;
4260                 auint = SvUV(fromstr);
4261                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4262             }
4263             break;
4264         case 'w':
4265             while (len-- > 0) {
4266                 fromstr = NEXTFROM;
4267                 adouble = floor(SvNV(fromstr));
4268
4269                 if (adouble < 0)
4270                     croak("Cannot compress negative numbers");
4271
4272                 if (
4273 #ifdef BW_BITS
4274                     adouble <= BW_MASK
4275 #else
4276 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4277                     adouble <= UV_MAX_cxux
4278 #else
4279                     adouble <= UV_MAX
4280 #endif
4281 #endif
4282                     )
4283                 {
4284                     char   buf[1 + sizeof(UV)];
4285                     char  *in = buf + sizeof(buf);
4286                     UV     auv = U_V(adouble);;
4287
4288                     do {
4289                         *--in = (auv & 0x7f) | 0x80;
4290                         auv >>= 7;
4291                     } while (auv);
4292                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4293                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4294                 }
4295                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4296                     char           *from, *result, *in;
4297                     SV             *norm;
4298                     STRLEN          len;
4299                     bool            done;
4300
4301                     /* Copy string and check for compliance */
4302                     from = SvPV(fromstr, len);
4303                     if ((norm = is_an_int(from, len)) == NULL)
4304                         croak("can compress only unsigned integer");
4305
4306                     New('w', result, len, char);
4307                     in = result + len;
4308                     done = FALSE;
4309                     while (!done)
4310                         *--in = div128(norm, &done) | 0x80;
4311                     result[len - 1] &= 0x7F; /* clear continue bit */
4312                     sv_catpvn(cat, in, (result + len) - in);
4313                     Safefree(result);
4314                     SvREFCNT_dec(norm); /* free norm */
4315                 }
4316                 else if (SvNOKp(fromstr)) {
4317                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4318                     char  *in = buf + sizeof(buf);
4319
4320                     do {
4321                         double next = floor(adouble / 128);
4322                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4323                         if (--in < buf)  /* this cannot happen ;-) */
4324                             croak ("Cannot compress integer");
4325                         adouble = next;
4326                     } while (adouble > 0);
4327                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4328                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4329                 }
4330                 else
4331                     croak("Cannot compress non integer");
4332             }
4333             break;
4334         case 'i':
4335             while (len-- > 0) {
4336                 fromstr = NEXTFROM;
4337                 aint = SvIV(fromstr);
4338                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4339             }
4340             break;
4341         case 'N':
4342             while (len-- > 0) {
4343                 fromstr = NEXTFROM;
4344                 aulong = SvUV(fromstr);
4345 #ifdef HAS_HTONL
4346                 aulong = PerlSock_htonl(aulong);
4347 #endif
4348                 CAT32(cat, &aulong);
4349             }
4350             break;
4351         case 'V':
4352             while (len-- > 0) {
4353                 fromstr = NEXTFROM;
4354                 aulong = SvUV(fromstr);
4355 #ifdef HAS_HTOVL
4356                 aulong = htovl(aulong);
4357 #endif
4358                 CAT32(cat, &aulong);
4359             }
4360             break;
4361         case 'L':
4362             while (len-- > 0) {
4363                 fromstr = NEXTFROM;
4364                 aulong = SvUV(fromstr);
4365                 CAT32(cat, &aulong);
4366             }
4367             break;
4368         case 'l':
4369             while (len-- > 0) {
4370                 fromstr = NEXTFROM;
4371                 along = SvIV(fromstr);
4372                 CAT32(cat, &along);
4373             }
4374             break;
4375 #ifdef HAS_QUAD
4376         case 'Q':
4377             while (len-- > 0) {
4378                 fromstr = NEXTFROM;
4379                 auquad = (unsigned Quad_t)SvIV(fromstr);
4380                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4381             }
4382             break;
4383         case 'q':
4384             while (len-- > 0) {
4385                 fromstr = NEXTFROM;
4386                 aquad = (Quad_t)SvIV(fromstr);
4387                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4388             }
4389             break;
4390 #endif /* HAS_QUAD */
4391         case 'P':
4392             len = 1;            /* assume SV is correct length */
4393             /* FALL THROUGH */
4394         case 'p':
4395             while (len-- > 0) {
4396                 fromstr = NEXTFROM;
4397                 if (fromstr == &PL_sv_undef)
4398                     aptr = NULL;
4399                 else {
4400                     /* XXX better yet, could spirit away the string to
4401                      * a safe spot and hang on to it until the result
4402                      * of pack() (and all copies of the result) are
4403                      * gone.
4404                      */
4405                     if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4406                         warn("Attempt to pack pointer to temporary value");
4407                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4408                         aptr = SvPV(fromstr,PL_na);
4409                     else
4410                         aptr = SvPV_force(fromstr,PL_na);
4411                 }
4412                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4413             }
4414             break;
4415         case 'u':
4416             fromstr = NEXTFROM;
4417             aptr = SvPV(fromstr, fromlen);
4418             SvGROW(cat, fromlen * 4 / 3);
4419             if (len <= 1)
4420                 len = 45;
4421             else
4422                 len = len / 3 * 3;
4423             while (fromlen > 0) {
4424                 I32 todo;
4425
4426                 if (fromlen > len)
4427                     todo = len;
4428                 else
4429                     todo = fromlen;
4430                 doencodes(cat, aptr, todo);
4431                 fromlen -= todo;
4432                 aptr += todo;
4433             }
4434             break;
4435         }
4436     }
4437     SvSETMAGIC(cat);
4438     SP = ORIGMARK;
4439     PUSHs(cat);
4440     RETURN;
4441 }
4442 #undef NEXTFROM
4443
4444
4445 PP(pp_split)
4446 {
4447     djSP; dTARG;
4448     AV *ary;
4449     register I32 limit = POPi;                  /* note, negative is forever */
4450     SV *sv = POPs;
4451     STRLEN len;
4452     register char *s = SvPV(sv, len);
4453     char *strend = s + len;
4454     register PMOP *pm;
4455     register REGEXP *rx;
4456     register SV *dstr;
4457     register char *m;
4458     I32 iters = 0;
4459     I32 maxiters = (strend - s) + 10;
4460     I32 i;
4461     char *orig;
4462     I32 origlimit = limit;
4463     I32 realarray = 0;
4464     I32 base;
4465     AV *oldstack = PL_curstack;
4466     I32 gimme = GIMME_V;
4467     I32 oldsave = PL_savestack_ix;
4468     I32 make_mortal = 1;
4469     MAGIC *mg = (MAGIC *) NULL;
4470
4471 #ifdef DEBUGGING
4472     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4473 #else
4474     pm = (PMOP*)POPs;
4475 #endif
4476     if (!pm || !s)
4477         DIE("panic: do_split");
4478     rx = pm->op_pmregexp;
4479
4480     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4481              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4482
4483     if (pm->op_pmreplroot)
4484         ary = GvAVn((GV*)pm->op_pmreplroot);
4485     else if (gimme != G_ARRAY)
4486 #ifdef USE_THREADS
4487         ary = (AV*)PL_curpad[0];
4488 #else
4489         ary = GvAVn(PL_defgv);
4490 #endif /* USE_THREADS */
4491     else
4492         ary = Nullav;
4493     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4494         realarray = 1;
4495         PUTBACK;
4496         av_extend(ary,0);
4497         av_clear(ary);
4498         SPAGAIN;
4499         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4500             PUSHMARK(SP);
4501             XPUSHs(mg->mg_obj);
4502         }
4503         else {
4504             if (!AvREAL(ary)) {
4505                 AvREAL_on(ary);
4506                 for (i = AvFILLp(ary); i >= 0; i--)
4507                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4508             }
4509             /* temporarily switch stacks */
4510             SWITCHSTACK(PL_curstack, ary);
4511             make_mortal = 0;
4512         }
4513     }
4514     base = SP - PL_stack_base;
4515     orig = s;
4516     if (pm->op_pmflags & PMf_SKIPWHITE) {
4517         if (pm->op_pmflags & PMf_LOCALE) {
4518             while (isSPACE_LC(*s))
4519                 s++;
4520         }
4521         else {
4522             while (isSPACE(*s))
4523                 s++;
4524         }
4525     }
4526     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4527         SAVEINT(PL_multiline);
4528         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4529     }
4530
4531     if (!limit)
4532         limit = maxiters + 2;
4533     if (pm->op_pmflags & PMf_WHITE) {
4534         while (--limit) {
4535             m = s;
4536             while (m < strend &&
4537                    !((pm->op_pmflags & PMf_LOCALE)
4538                      ? isSPACE_LC(*m) : isSPACE(*m)))
4539                 ++m;
4540             if (m >= strend)
4541                 break;
4542
4543             dstr = NEWSV(30, m-s);
4544             sv_setpvn(dstr, s, m-s);
4545             if (make_mortal)
4546                 sv_2mortal(dstr);
4547             XPUSHs(dstr);
4548
4549             s = m + 1;
4550             while (s < strend &&
4551                    ((pm->op_pmflags & PMf_LOCALE)
4552                     ? isSPACE_LC(*s) : isSPACE(*s)))
4553                 ++s;
4554         }
4555     }
4556     else if (strEQ("^", rx->precomp)) {
4557         while (--limit) {
4558             /*SUPPRESS 530*/
4559             for (m = s; m < strend && *m != '\n'; m++) ;
4560             m++;
4561             if (m >= strend)
4562                 break;
4563             dstr = NEWSV(30, m-s);
4564             sv_setpvn(dstr, s, m-s);
4565             if (make_mortal)
4566                 sv_2mortal(dstr);
4567             XPUSHs(dstr);
4568             s = m;
4569         }
4570     }
4571     else if (rx->check_substr && !rx->nparens
4572              && (rx->reganch & ROPT_CHECK_ALL)
4573              && !(rx->reganch & ROPT_ANCH)) {
4574         i = SvCUR(rx->check_substr);
4575         if (i == 1 && !SvTAIL(rx->check_substr)) {
4576             i = *SvPVX(rx->check_substr);
4577             while (--limit) {
4578                 /*SUPPRESS 530*/
4579                 for (m = s; m < strend && *m != i; m++) ;
4580                 if (m >= strend)
4581                     break;
4582                 dstr = NEWSV(30, m-s);
4583                 sv_setpvn(dstr, s, m-s);
4584                 if (make_mortal)
4585                     sv_2mortal(dstr);
4586                 XPUSHs(dstr);
4587                 s = m + 1;
4588             }
4589         }
4590         else {
4591 #ifndef lint
4592             while (s < strend && --limit &&
4593               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4594                     rx->check_substr, 0)) )
4595 #endif
4596             {
4597                 dstr = NEWSV(31, m-s);
4598                 sv_setpvn(dstr, s, m-s);
4599                 if (make_mortal)
4600                     sv_2mortal(dstr);
4601                 XPUSHs(dstr);
4602                 s = m + i;
4603             }
4604         }
4605     }
4606     else {
4607         maxiters += (strend - s) * rx->nparens;
4608         while (s < strend && --limit &&
4609                CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4610         {
4611             TAINT_IF(RX_MATCH_TAINTED(rx));
4612             if (rx->subbase
4613               && rx->subbase != orig) {
4614                 m = s;
4615                 s = orig;
4616                 orig = rx->subbase;
4617                 s = orig + (m - s);
4618                 strend = s + (strend - m);
4619             }
4620             m = rx->startp[0];
4621             dstr = NEWSV(32, m-s);
4622             sv_setpvn(dstr, s, m-s);
4623             if (make_mortal)
4624                 sv_2mortal(dstr);
4625             XPUSHs(dstr);
4626             if (rx->nparens) {
4627                 for (i = 1; i <= rx->nparens; i++) {
4628                     s = rx->startp[i];
4629                     m = rx->endp[i];
4630                     if (m && s) {
4631                         dstr = NEWSV(33, m-s);
4632                         sv_setpvn(dstr, s, m-s);
4633                     }
4634                     else
4635                         dstr = NEWSV(33, 0);
4636                     if (make_mortal)
4637                         sv_2mortal(dstr);
4638                     XPUSHs(dstr);
4639                 }
4640             }
4641             s = rx->endp[0];
4642         }
4643     }
4644
4645     LEAVE_SCOPE(oldsave);
4646     iters = (SP - PL_stack_base) - base;
4647     if (iters > maxiters)
4648         DIE("Split loop");
4649
4650     /* keep field after final delim? */
4651     if (s < strend || (iters && origlimit)) {
4652         dstr = NEWSV(34, strend-s);
4653         sv_setpvn(dstr, s, strend-s);
4654         if (make_mortal)
4655             sv_2mortal(dstr);
4656         XPUSHs(dstr);
4657         iters++;
4658     }
4659     else if (!origlimit) {
4660         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4661             iters--, SP--;
4662     }
4663
4664     if (realarray) {
4665         if (!mg) {
4666             SWITCHSTACK(ary, oldstack);
4667             if (SvSMAGICAL(ary)) {
4668                 PUTBACK;
4669                 mg_set((SV*)ary);
4670                 SPAGAIN;
4671             }
4672             if (gimme == G_ARRAY) {
4673                 EXTEND(SP, iters);
4674                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4675                 SP += iters;
4676                 RETURN;
4677             }
4678         }
4679         else {
4680             PUTBACK;
4681             ENTER;
4682             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4683             LEAVE;
4684             SPAGAIN;
4685             if (gimme == G_ARRAY) {
4686                 /* EXTEND should not be needed - we just popped them */
4687                 EXTEND(SP, iters);
4688                 for (i=0; i < iters; i++) {
4689                     SV **svp = av_fetch(ary, i, FALSE);
4690                     PUSHs((svp) ? *svp : &PL_sv_undef);
4691                 }
4692                 RETURN;
4693             }
4694         }
4695     }
4696     else {
4697         if (gimme == G_ARRAY)
4698             RETURN;
4699     }
4700     if (iters || !pm->op_pmreplroot) {
4701         GETTARGET;
4702         PUSHi(iters);
4703         RETURN;
4704     }
4705     RETPUSHUNDEF;
4706 }
4707
4708 #ifdef USE_THREADS
4709 void
4710 unlock_condpair(void *svv)
4711 {
4712     dTHR;
4713     MAGIC *mg = mg_find((SV*)svv, 'm');
4714
4715     if (!mg)
4716         croak("panic: unlock_condpair unlocking non-mutex");
4717     MUTEX_LOCK(MgMUTEXP(mg));
4718     if (MgOWNER(mg) != thr)
4719         croak("panic: unlock_condpair unlocking mutex that we don't own");
4720     MgOWNER(mg) = 0;
4721     COND_SIGNAL(MgOWNERCONDP(mg));
4722     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4723                           (unsigned long)thr, (unsigned long)svv);)
4724     MUTEX_UNLOCK(MgMUTEXP(mg));
4725 }
4726 #endif /* USE_THREADS */
4727
4728 PP(pp_lock)
4729 {
4730     djSP;
4731     dTOPss;
4732     SV *retsv = sv;
4733 #ifdef USE_THREADS
4734     MAGIC *mg;
4735
4736     if (SvROK(sv))
4737         sv = SvRV(sv);
4738
4739     mg = condpair_magic(sv);
4740     MUTEX_LOCK(MgMUTEXP(mg));
4741     if (MgOWNER(mg) == thr)
4742         MUTEX_UNLOCK(MgMUTEXP(mg));
4743     else {
4744         while (MgOWNER(mg))
4745             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4746         MgOWNER(mg) = thr;
4747         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4748                               (unsigned long)thr, (unsigned long)sv);)
4749         MUTEX_UNLOCK(MgMUTEXP(mg));
4750         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4751         save_destructor(unlock_condpair, sv);
4752     }
4753 #endif /* USE_THREADS */
4754     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4755         || SvTYPE(retsv) == SVt_PVCV) {
4756         retsv = refto(retsv);
4757     }
4758     SETs(retsv);
4759     RETURN;
4760 }
4761
4762 PP(pp_threadsv)
4763 {
4764     djSP;
4765 #ifdef USE_THREADS
4766     EXTEND(SP, 1);
4767     if (PL_op->op_private & OPpLVAL_INTRO)
4768         PUSHs(*save_threadsv(PL_op->op_targ));
4769     else
4770         PUSHs(THREADSV(PL_op->op_targ));
4771     RETURN;
4772 #else
4773     DIE("tried to access per-thread data in non-threaded perl");
4774 #endif /* USE_THREADS */
4775 }