pp.c

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