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