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