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