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