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                     culong += auint;
3420                 }
3421             }
3422             else {
3423                 EXTEND(SP, len);
3424                 EXTEND_MORTAL(len);
3425                 while (len-- > 0 && s < strend) {
3426                     auint = utf8_to_uv((U8*)s, &along);
3427                     s += along;
3428                     sv = NEWSV(37, 0);
3429                     sv_setiv(sv, (IV)auint);
3430                     PUSHs(sv_2mortal(sv));
3431                 }
3432             }
3433             break;
3434         case 's':
3435             along = (strend - s) / SIZE16;
3436             if (len > along)
3437                 len = along;
3438             if (checksum) {
3439                 while (len-- > 0) {
3440                     COPY16(s, &ashort);
3441                     s += SIZE16;
3442                     culong += ashort;
3443                 }
3444             }
3445             else {
3446                 EXTEND(SP, len);
3447                 EXTEND_MORTAL(len);
3448                 while (len-- > 0) {
3449                     COPY16(s, &ashort);
3450                     s += SIZE16;
3451                     sv = NEWSV(38, 0);
3452                     sv_setiv(sv, (IV)ashort);
3453                     PUSHs(sv_2mortal(sv));
3454                 }
3455             }
3456             break;
3457         case 'v':
3458         case 'n':
3459         case 'S':
3460             along = (strend - s) / SIZE16;
3461             if (len > along)
3462                 len = along;
3463             if (checksum) {
3464                 while (len-- > 0) {
3465                     COPY16(s, &aushort);
3466                     s += SIZE16;
3467 #ifdef HAS_NTOHS
3468                     if (datumtype == 'n')
3469                         aushort = PerlSock_ntohs(aushort);
3470 #endif
3471 #ifdef HAS_VTOHS
3472                     if (datumtype == 'v')
3473                         aushort = vtohs(aushort);
3474 #endif
3475                     culong += aushort;
3476                 }
3477             }
3478             else {
3479                 EXTEND(SP, len);
3480                 EXTEND_MORTAL(len);
3481                 while (len-- > 0) {
3482                     COPY16(s, &aushort);
3483                     s += SIZE16;
3484                     sv = NEWSV(39, 0);
3485 #ifdef HAS_NTOHS
3486                     if (datumtype == 'n')
3487                         aushort = PerlSock_ntohs(aushort);
3488 #endif
3489 #ifdef HAS_VTOHS
3490                     if (datumtype == 'v')
3491                         aushort = vtohs(aushort);
3492 #endif
3493                     sv_setiv(sv, (IV)aushort);
3494                     PUSHs(sv_2mortal(sv));
3495                 }
3496             }
3497             break;
3498         case 'i':
3499             along = (strend - s) / sizeof(int);
3500             if (len > along)
3501                 len = along;
3502             if (checksum) {
3503                 while (len-- > 0) {
3504                     Copy(s, &aint, 1, int);
3505                     s += sizeof(int);
3506                     if (checksum > 32)
3507                         cdouble += (double)aint;
3508                     else
3509                         culong += aint;
3510                 }
3511             }
3512             else {
3513                 EXTEND(SP, len);
3514                 EXTEND_MORTAL(len);
3515                 while (len-- > 0) {
3516                     Copy(s, &aint, 1, int);
3517                     s += sizeof(int);
3518                     sv = NEWSV(40, 0);
3519 #ifdef __osf__
3520                     /* Without the dummy below unpack("i", pack("i",-1))
3521                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3522                      * cc with optimization turned on */
3523                     (aint) ?
3524                         sv_setiv(sv, (IV)aint) :
3525 #endif
3526                     sv_setiv(sv, (IV)aint);
3527                     PUSHs(sv_2mortal(sv));
3528                 }
3529             }
3530             break;
3531         case 'I':
3532             along = (strend - s) / sizeof(unsigned int);
3533             if (len > along)
3534                 len = along;
3535             if (checksum) {
3536                 while (len-- > 0) {
3537                     Copy(s, &auint, 1, unsigned int);
3538                     s += sizeof(unsigned int);
3539                     if (checksum > 32)
3540                         cdouble += (double)auint;
3541                     else
3542                         culong += auint;
3543                 }
3544             }
3545             else {
3546                 EXTEND(SP, len);
3547                 EXTEND_MORTAL(len);
3548                 while (len-- > 0) {
3549                     Copy(s, &auint, 1, unsigned int);
3550                     s += sizeof(unsigned int);
3551                     sv = NEWSV(41, 0);
3552                     sv_setuv(sv, (UV)auint);
3553                     PUSHs(sv_2mortal(sv));
3554                 }
3555             }
3556             break;
3557         case 'l':
3558             along = (strend - s) / SIZE32;
3559             if (len > along)
3560                 len = along;
3561             if (checksum) {
3562                 while (len-- > 0) {
3563                     COPY32(s, &along);
3564                     s += SIZE32;
3565                     if (checksum > 32)
3566                         cdouble += (double)along;
3567                     else
3568                         culong += along;
3569                 }
3570             }
3571             else {
3572                 EXTEND(SP, len);
3573                 EXTEND_MORTAL(len);
3574                 while (len-- > 0) {
3575                     COPY32(s, &along);
3576                     s += SIZE32;
3577                     sv = NEWSV(42, 0);
3578                     sv_setiv(sv, (IV)along);
3579                     PUSHs(sv_2mortal(sv));
3580                 }
3581             }
3582             break;
3583         case 'V':
3584         case 'N':
3585         case 'L':
3586             along = (strend - s) / SIZE32;
3587             if (len > along)
3588                 len = along;
3589             if (checksum) {
3590                 while (len-- > 0) {
3591                     COPY32(s, &aulong);
3592                     s += SIZE32;
3593 #ifdef HAS_NTOHL
3594                     if (datumtype == 'N')
3595                         aulong = PerlSock_ntohl(aulong);
3596 #endif
3597 #ifdef HAS_VTOHL
3598                     if (datumtype == 'V')
3599                         aulong = vtohl(aulong);
3600 #endif
3601                     if (checksum > 32)
3602                         cdouble += (double)aulong;
3603                     else
3604                         culong += aulong;
3605                 }
3606             }
3607             else {
3608                 EXTEND(SP, len);
3609                 EXTEND_MORTAL(len);
3610                 while (len-- > 0) {
3611                     COPY32(s, &aulong);
3612                     s += SIZE32;
3613 #ifdef HAS_NTOHL
3614                     if (datumtype == 'N')
3615                         aulong = PerlSock_ntohl(aulong);
3616 #endif
3617 #ifdef HAS_VTOHL
3618                     if (datumtype == 'V')
3619                         aulong = vtohl(aulong);
3620 #endif
3621                     sv = NEWSV(43, 0);
3622                     sv_setuv(sv, (UV)aulong);
3623                     PUSHs(sv_2mortal(sv));
3624                 }
3625             }
3626             break;
3627         case 'p':
3628             along = (strend - s) / sizeof(char*);
3629             if (len > along)
3630                 len = along;
3631             EXTEND(SP, len);
3632             EXTEND_MORTAL(len);
3633             while (len-- > 0) {
3634                 if (sizeof(char*) > strend - s)
3635                     break;
3636                 else {
3637                     Copy(s, &aptr, 1, char*);
3638                     s += sizeof(char*);
3639                 }
3640                 sv = NEWSV(44, 0);
3641                 if (aptr)
3642                     sv_setpv(sv, aptr);
3643                 PUSHs(sv_2mortal(sv));
3644             }
3645             break;
3646         case 'w':
3647             EXTEND(SP, len);
3648             EXTEND_MORTAL(len);
3649             {
3650                 UV auv = 0;
3651                 U32 bytes = 0;
3652
3653                 while ((len > 0) && (s < strend)) {
3654                     auv = (auv << 7) | (*s & 0x7f);
3655                     if (!(*s++ & 0x80)) {
3656                         bytes = 0;
3657                         sv = NEWSV(40, 0);
3658                         sv_setuv(sv, auv);
3659                         PUSHs(sv_2mortal(sv));
3660                         len--;
3661                         auv = 0;
3662                     }
3663                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3664                         char *t;
3665
3666                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3667                         while (s < strend) {
3668                             sv = mul128(sv, *s & 0x7f);
3669                             if (!(*s++ & 0x80)) {
3670                                 bytes = 0;
3671                                 break;
3672                             }
3673                         }
3674                         t = SvPV(sv, PL_na);
3675                         while (*t == '0')
3676                             t++;
3677                         sv_chop(sv, t);
3678                         PUSHs(sv_2mortal(sv));
3679                         len--;
3680                         auv = 0;
3681                     }
3682                 }
3683                 if ((s >= strend) && bytes)
3684                     croak("Unterminated compressed integer");
3685             }
3686             break;
3687         case 'P':
3688             EXTEND(SP, 1);
3689             if (sizeof(char*) > strend - s)
3690                 break;
3691             else {
3692                 Copy(s, &aptr, 1, char*);
3693                 s += sizeof(char*);
3694             }
3695             sv = NEWSV(44, 0);
3696             if (aptr)
3697                 sv_setpvn(sv, aptr, len);
3698             PUSHs(sv_2mortal(sv));
3699             break;
3700 #ifdef HAS_QUAD
3701         case 'q':
3702             along = (strend - s) / sizeof(Quad_t);
3703             if (len > along)
3704                 len = along;
3705             EXTEND(SP, len);
3706             EXTEND_MORTAL(len);
3707             while (len-- > 0) {
3708                 if (s + sizeof(Quad_t) > strend)
3709                     aquad = 0;
3710                 else {
3711                     Copy(s, &aquad, 1, Quad_t);
3712                     s += sizeof(Quad_t);
3713                 }
3714                 sv = NEWSV(42, 0);
3715                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3716                     sv_setiv(sv, (IV)aquad);
3717                 else
3718                     sv_setnv(sv, (double)aquad);
3719                 PUSHs(sv_2mortal(sv));
3720             }
3721             break;
3722         case 'Q':
3723             along = (strend - s) / sizeof(Quad_t);
3724             if (len > along)
3725                 len = along;
3726             EXTEND(SP, len);
3727             EXTEND_MORTAL(len);
3728             while (len-- > 0) {
3729                 if (s + sizeof(unsigned Quad_t) > strend)
3730                     auquad = 0;
3731                 else {
3732                     Copy(s, &auquad, 1, unsigned Quad_t);
3733                     s += sizeof(unsigned Quad_t);
3734                 }
3735                 sv = NEWSV(43, 0);
3736                 if (auquad <= UV_MAX)
3737                     sv_setuv(sv, (UV)auquad);
3738                 else
3739                     sv_setnv(sv, (double)auquad);
3740                 PUSHs(sv_2mortal(sv));
3741             }
3742             break;
3743 #endif
3744         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3745         case 'f':
3746         case 'F':
3747             along = (strend - s) / sizeof(float);
3748             if (len > along)
3749                 len = along;
3750             if (checksum) {
3751                 while (len-- > 0) {
3752                     Copy(s, &afloat, 1, float);
3753                     s += sizeof(float);
3754                     cdouble += afloat;
3755                 }
3756             }
3757             else {
3758                 EXTEND(SP, len);
3759                 EXTEND_MORTAL(len);
3760                 while (len-- > 0) {
3761                     Copy(s, &afloat, 1, float);
3762                     s += sizeof(float);
3763                     sv = NEWSV(47, 0);
3764                     sv_setnv(sv, (double)afloat);
3765                     PUSHs(sv_2mortal(sv));
3766                 }
3767             }
3768             break;
3769         case 'd':
3770         case 'D':
3771             along = (strend - s) / sizeof(double);
3772             if (len > along)
3773                 len = along;
3774             if (checksum) {
3775                 while (len-- > 0) {
3776                     Copy(s, &adouble, 1, double);
3777                     s += sizeof(double);
3778                     cdouble += adouble;
3779                 }
3780             }
3781             else {
3782                 EXTEND(SP, len);
3783                 EXTEND_MORTAL(len);
3784                 while (len-- > 0) {
3785                     Copy(s, &adouble, 1, double);
3786                     s += sizeof(double);
3787                     sv = NEWSV(48, 0);
3788                     sv_setnv(sv, (double)adouble);
3789                     PUSHs(sv_2mortal(sv));
3790                 }
3791             }
3792             break;
3793         case 'u':
3794             /* MKS:
3795              * Initialise the decode mapping.  By using a table driven
3796              * algorithm, the code will be character-set independent
3797              * (and just as fast as doing character arithmetic)
3798              */
3799             if (uudmap['M'] == 0) {
3800                 int i;
3801
3802                 for (i = 0; i < sizeof(uuemap); i += 1)
3803                     uudmap[uuemap[i]] = i;
3804                 /*
3805                  * Because ' ' and '`' map to the same value,
3806                  * we need to decode them both the same.
3807                  */
3808                 uudmap[' '] = 0;
3809             }
3810
3811             along = (strend - s) * 3 / 4;
3812             sv = NEWSV(42, along);
3813             if (along)
3814                 SvPOK_on(sv);
3815             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3816                 I32 a, b, c, d;
3817                 char hunk[4];
3818
3819                 hunk[3] = '\0';
3820                 len = uudmap[*s++] & 077;
3821                 while (len > 0) {
3822                     if (s < strend && ISUUCHAR(*s))
3823                         a = uudmap[*s++] & 077;
3824                     else
3825                         a = 0;
3826                     if (s < strend && ISUUCHAR(*s))
3827                         b = uudmap[*s++] & 077;
3828                     else
3829                         b = 0;
3830                     if (s < strend && ISUUCHAR(*s))
3831                         c = uudmap[*s++] & 077;
3832                     else
3833                         c = 0;
3834                     if (s < strend && ISUUCHAR(*s))
3835                         d = uudmap[*s++] & 077;
3836                     else
3837                         d = 0;
3838                     hunk[0] = (a << 2) | (b >> 4);
3839                     hunk[1] = (b << 4) | (c >> 2);
3840                     hunk[2] = (c << 6) | d;
3841                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3842                     len -= 3;
3843                 }
3844                 if (*s == '\n')
3845                     s++;
3846                 else if (s[1] == '\n')          /* possible checksum byte */
3847                     s += 2;
3848             }
3849             XPUSHs(sv_2mortal(sv));
3850             break;
3851         }
3852         if (checksum) {
3853             sv = NEWSV(42, 0);
3854             if (strchr("fFdD", datumtype) ||
3855               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3856                 double trouble;
3857
3858                 adouble = 1.0;
3859                 while (checksum >= 16) {
3860                     checksum -= 16;
3861                     adouble *= 65536.0;
3862                 }
3863                 while (checksum >= 4) {
3864                     checksum -= 4;
3865                     adouble *= 16.0;
3866                 }
3867                 while (checksum--)
3868                     adouble *= 2.0;
3869                 along = (1 << checksum) - 1;
3870                 while (cdouble < 0.0)
3871                     cdouble += adouble;
3872                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3873                 sv_setnv(sv, cdouble);
3874             }
3875             else {
3876                 if (checksum < 32) {
3877                     aulong = (1 << checksum) - 1;
3878                     culong &= aulong;
3879                 }
3880                 sv_setuv(sv, (UV)culong);
3881             }
3882             XPUSHs(sv_2mortal(sv));
3883             checksum = 0;
3884         }
3885     }
3886     if (SP == oldsp && gimme == G_SCALAR)
3887         PUSHs(&PL_sv_undef);
3888     RETURN;
3889 }
3890
3891 STATIC void
3892 doencodes(register SV *sv, register char *s, register I32 len)
3893 {
3894     char hunk[5];
3895
3896     *hunk = uuemap[len];
3897     sv_catpvn(sv, hunk, 1);
3898     hunk[4] = '\0';
3899     while (len > 2) {
3900         hunk[0] = uuemap[(077 & (*s >> 2))];
3901         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3902         hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3903         hunk[3] = uuemap[(077 & (s[2] & 077))];
3904         sv_catpvn(sv, hunk, 4);
3905         s += 3;
3906         len -= 3;
3907     }
3908     if (len > 0) {
3909         char r = (len > 1 ? s[1] : '\0');
3910         hunk[0] = uuemap[(077 & (*s >> 2))];
3911         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3912         hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3913         hunk[3] = uuemap[0];
3914         sv_catpvn(sv, hunk, 4);
3915     }
3916     sv_catpvn(sv, "\n", 1);
3917 }
3918
3919 STATIC SV      *
3920 is_an_int(char *s, STRLEN l)
3921 {
3922   SV             *result = newSVpv("", l);
3923   char           *result_c = SvPV(result, PL_na);       /* convenience */
3924   char           *out = result_c;
3925   bool            skip = 1;
3926   bool            ignore = 0;
3927
3928   while (*s) {
3929     switch (*s) {
3930     case ' ':
3931       break;
3932     case '+':
3933       if (!skip) {
3934         SvREFCNT_dec(result);
3935         return (NULL);
3936       }
3937       break;
3938     case '0':
3939     case '1':
3940     case '2':
3941     case '3':
3942     case '4':
3943     case '5':
3944     case '6':
3945     case '7':
3946     case '8':
3947     case '9':
3948       skip = 0;
3949       if (!ignore) {
3950         *(out++) = *s;
3951       }
3952       break;
3953     case '.':
3954       ignore = 1;
3955       break;
3956     default:
3957       SvREFCNT_dec(result);
3958       return (NULL);
3959     }
3960     s++;
3961   }
3962   *(out++) = '\0';
3963   SvCUR_set(result, out - result_c);
3964   return (result);
3965 }
3966
3967 STATIC int
3968 div128(SV *pnum, bool *done)
3969                                             /* must be '\0' terminated */
3970
3971 {
3972   STRLEN          len;
3973   char           *s = SvPV(pnum, len);
3974   int             m = 0;
3975   int             r = 0;
3976   char           *t = s;
3977
3978   *done = 1;
3979   while (*t) {
3980     int             i;
3981
3982     i = m * 10 + (*t - '0');
3983     m = i & 0x7F;
3984     r = (i >> 7);               /* r < 10 */
3985     if (r) {
3986       *done = 0;
3987     }
3988     *(t++) = '0' + r;
3989   }
3990   *(t++) = '\0';
3991   SvCUR_set(pnum, (STRLEN) (t - s));
3992   return (m);
3993 }
3994
3995
3996 PP(pp_pack)
3997 {
3998     djSP; dMARK; dORIGMARK; dTARGET;
3999     register SV *cat = TARG;
4000     register I32 items;
4001     STRLEN fromlen;
4002     register char *pat = SvPVx(*++MARK, fromlen);
4003     register char *patend = pat + fromlen;
4004     register I32 len;
4005     I32 datumtype;
4006     SV *fromstr;
4007     /*SUPPRESS 442*/
4008     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4009     static char *space10 = "          ";
4010
4011     /* These must not be in registers: */
4012     char achar;
4013     I16 ashort;
4014     int aint;
4015     unsigned int auint;
4016     I32 along;
4017     U32 aulong;
4018 #ifdef HAS_QUAD
4019     Quad_t aquad;
4020     unsigned Quad_t auquad;
4021 #endif
4022     char *aptr;
4023     float afloat;
4024     double adouble;
4025     int commas = 0;
4026
4027     items = SP - MARK;
4028     MARK++;
4029     sv_setpvn(cat, "", 0);
4030     while (pat < patend) {
4031 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4032         datumtype = *pat++ & 0xFF;
4033         if (isSPACE(datumtype))
4034             continue;
4035         if (*pat == '*') {
4036             len = strchr("@Xxu", datumtype) ? 0 : items;
4037             pat++;
4038         }
4039         else if (isDIGIT(*pat)) {
4040             len = *pat++ - '0';
4041             while (isDIGIT(*pat))
4042                 len = (len * 10) + (*pat++ - '0');
4043         }
4044         else
4045             len = 1;
4046         switch(datumtype) {
4047         default:
4048             croak("Invalid type in pack: '%c'", (int)datumtype);
4049         case ',': /* grandfather in commas but with a warning */
4050             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4051                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4052             break;
4053         case '%':
4054             DIE("%% may only be used in unpack");
4055         case '@':
4056             len -= SvCUR(cat);
4057             if (len > 0)
4058                 goto grow;
4059             len = -len;
4060             if (len > 0)
4061                 goto shrink;
4062             break;
4063         case 'X':
4064           shrink:
4065             if (SvCUR(cat) < len)
4066                 DIE("X outside of string");
4067             SvCUR(cat) -= len;
4068             *SvEND(cat) = '\0';
4069             break;
4070         case 'x':
4071           grow:
4072             while (len >= 10) {
4073                 sv_catpvn(cat, null10, 10);
4074                 len -= 10;
4075             }
4076             sv_catpvn(cat, null10, len);
4077             break;
4078         case 'A':
4079         case 'a':
4080             fromstr = NEXTFROM;
4081             aptr = SvPV(fromstr, fromlen);
4082             if (pat[-1] == '*')
4083                 len = fromlen;
4084             if (fromlen > len)
4085                 sv_catpvn(cat, aptr, len);
4086             else {
4087                 sv_catpvn(cat, aptr, fromlen);
4088                 len -= fromlen;
4089                 if (datumtype == 'A') {
4090                     while (len >= 10) {
4091                         sv_catpvn(cat, space10, 10);
4092                         len -= 10;
4093                     }
4094                     sv_catpvn(cat, space10, len);
4095                 }
4096                 else {
4097                     while (len >= 10) {
4098                         sv_catpvn(cat, null10, 10);
4099                         len -= 10;
4100                     }
4101                     sv_catpvn(cat, null10, len);
4102                 }
4103             }
4104             break;
4105         case 'B':
4106         case 'b':
4107             {
4108                 char *savepat = pat;
4109                 I32 saveitems;
4110
4111                 fromstr = NEXTFROM;
4112                 saveitems = items;
4113                 aptr = SvPV(fromstr, fromlen);
4114                 if (pat[-1] == '*')
4115                     len = fromlen;
4116                 pat = aptr;
4117                 aint = SvCUR(cat);
4118                 SvCUR(cat) += (len+7)/8;
4119                 SvGROW(cat, SvCUR(cat) + 1);
4120                 aptr = SvPVX(cat) + aint;
4121                 if (len > fromlen)
4122                     len = fromlen;
4123                 aint = len;
4124                 items = 0;
4125                 if (datumtype == 'B') {
4126                     for (len = 0; len++ < aint;) {
4127                         items |= *pat++ & 1;
4128                         if (len & 7)
4129                             items <<= 1;
4130                         else {
4131                             *aptr++ = items & 0xff;
4132                             items = 0;
4133                         }
4134                     }
4135                 }
4136                 else {
4137                     for (len = 0; len++ < aint;) {
4138                         if (*pat++ & 1)
4139                             items |= 128;
4140                         if (len & 7)
4141                             items >>= 1;
4142                         else {
4143                             *aptr++ = items & 0xff;
4144                             items = 0;
4145                         }
4146                     }
4147                 }
4148                 if (aint & 7) {
4149                     if (datumtype == 'B')
4150                         items <<= 7 - (aint & 7);
4151                     else
4152                         items >>= 7 - (aint & 7);
4153                     *aptr++ = items & 0xff;
4154                 }
4155                 pat = SvPVX(cat) + SvCUR(cat);
4156                 while (aptr <= pat)
4157                     *aptr++ = '\0';
4158
4159                 pat = savepat;
4160                 items = saveitems;
4161             }
4162             break;
4163         case 'H':
4164         case 'h':
4165             {
4166                 char *savepat = pat;
4167                 I32 saveitems;
4168
4169                 fromstr = NEXTFROM;
4170                 saveitems = items;
4171                 aptr = SvPV(fromstr, fromlen);
4172                 if (pat[-1] == '*')
4173                     len = fromlen;
4174                 pat = aptr;
4175                 aint = SvCUR(cat);
4176                 SvCUR(cat) += (len+1)/2;
4177                 SvGROW(cat, SvCUR(cat) + 1);
4178                 aptr = SvPVX(cat) + aint;
4179                 if (len > fromlen)
4180                     len = fromlen;
4181                 aint = len;
4182                 items = 0;
4183                 if (datumtype == 'H') {
4184                     for (len = 0; len++ < aint;) {
4185                         if (isALPHA(*pat))
4186                             items |= ((*pat++ & 15) + 9) & 15;
4187                         else
4188                             items |= *pat++ & 15;
4189                         if (len & 1)
4190                             items <<= 4;
4191                         else {
4192                             *aptr++ = items & 0xff;
4193                             items = 0;
4194                         }
4195                     }
4196                 }
4197                 else {
4198                     for (len = 0; len++ < aint;) {
4199                         if (isALPHA(*pat))
4200                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4201                         else
4202                             items |= (*pat++ & 15) << 4;
4203                         if (len & 1)
4204                             items >>= 4;
4205                         else {
4206                             *aptr++ = items & 0xff;
4207                             items = 0;
4208                         }
4209                     }
4210                 }
4211                 if (aint & 1)
4212                     *aptr++ = items & 0xff;
4213                 pat = SvPVX(cat) + SvCUR(cat);
4214                 while (aptr <= pat)
4215                     *aptr++ = '\0';
4216
4217                 pat = savepat;
4218                 items = saveitems;
4219             }
4220             break;
4221         case 'C':
4222         case 'c':
4223             while (len-- > 0) {
4224                 fromstr = NEXTFROM;
4225                 aint = SvIV(fromstr);
4226                 achar = aint;
4227                 sv_catpvn(cat, &achar, sizeof(char));
4228             }
4229             break;
4230         case 'U':
4231             while (len-- > 0) {
4232                 fromstr = NEXTFROM;
4233                 auint = SvUV(fromstr);
4234                 SvGROW(cat, SvCUR(cat) + 10);
4235                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4236                                - SvPVX(cat));
4237             }
4238             *SvEND(cat) = '\0';
4239             break;
4240         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4241         case 'f':
4242         case 'F':
4243             while (len-- > 0) {
4244                 fromstr = NEXTFROM;
4245                 afloat = (float)SvNV(fromstr);
4246                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4247             }
4248             break;
4249         case 'd':
4250         case 'D':
4251             while (len-- > 0) {
4252                 fromstr = NEXTFROM;
4253                 adouble = (double)SvNV(fromstr);
4254                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4255             }
4256             break;
4257         case 'n':
4258             while (len-- > 0) {
4259                 fromstr = NEXTFROM;
4260                 ashort = (I16)SvIV(fromstr);
4261 #ifdef HAS_HTONS
4262                 ashort = PerlSock_htons(ashort);
4263 #endif
4264                 CAT16(cat, &ashort);
4265             }
4266             break;
4267         case 'v':
4268             while (len-- > 0) {
4269                 fromstr = NEXTFROM;
4270                 ashort = (I16)SvIV(fromstr);
4271 #ifdef HAS_HTOVS
4272                 ashort = htovs(ashort);
4273 #endif
4274                 CAT16(cat, &ashort);
4275             }
4276             break;
4277         case 'S':
4278         case 's':
4279             while (len-- > 0) {
4280                 fromstr = NEXTFROM;
4281                 ashort = (I16)SvIV(fromstr);
4282                 CAT16(cat, &ashort);
4283             }
4284             break;
4285         case 'I':
4286             while (len-- > 0) {
4287                 fromstr = NEXTFROM;
4288                 auint = SvUV(fromstr);
4289                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4290             }
4291             break;
4292         case 'w':
4293             while (len-- > 0) {
4294                 fromstr = NEXTFROM;
4295                 adouble = floor(SvNV(fromstr));
4296
4297                 if (adouble < 0)
4298                     croak("Cannot compress negative numbers");
4299
4300                 if (
4301 #ifdef BW_BITS
4302                     adouble <= BW_MASK
4303 #else
4304 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4305                     adouble <= UV_MAX_cxux
4306 #else
4307                     adouble <= UV_MAX
4308 #endif
4309 #endif
4310                     )
4311                 {
4312                     char   buf[1 + sizeof(UV)];
4313                     char  *in = buf + sizeof(buf);
4314                     UV     auv = U_V(adouble);;
4315
4316                     do {
4317                         *--in = (auv & 0x7f) | 0x80;
4318                         auv >>= 7;
4319                     } while (auv);
4320                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4321                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4322                 }
4323                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4324                     char           *from, *result, *in;
4325                     SV             *norm;
4326                     STRLEN          len;
4327                     bool            done;
4328
4329                     /* Copy string and check for compliance */
4330                     from = SvPV(fromstr, len);
4331                     if ((norm = is_an_int(from, len)) == NULL)
4332                         croak("can compress only unsigned integer");
4333
4334                     New('w', result, len, char);
4335                     in = result + len;
4336                     done = FALSE;
4337                     while (!done)
4338                         *--in = div128(norm, &done) | 0x80;
4339                     result[len - 1] &= 0x7F; /* clear continue bit */
4340                     sv_catpvn(cat, in, (result + len) - in);
4341                     Safefree(result);
4342                     SvREFCNT_dec(norm); /* free norm */
4343                 }
4344                 else if (SvNOKp(fromstr)) {
4345                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4346                     char  *in = buf + sizeof(buf);
4347
4348                     do {
4349                         double next = floor(adouble / 128);
4350                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4351                         if (--in < buf)  /* this cannot happen ;-) */
4352                             croak ("Cannot compress integer");
4353                         adouble = next;
4354                     } while (adouble > 0);
4355                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4356                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4357                 }
4358                 else
4359                     croak("Cannot compress non integer");
4360             }
4361             break;
4362         case 'i':
4363             while (len-- > 0) {
4364                 fromstr = NEXTFROM;
4365                 aint = SvIV(fromstr);
4366                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4367             }
4368             break;
4369         case 'N':
4370             while (len-- > 0) {
4371                 fromstr = NEXTFROM;
4372                 aulong = SvUV(fromstr);
4373 #ifdef HAS_HTONL
4374                 aulong = PerlSock_htonl(aulong);
4375 #endif
4376                 CAT32(cat, &aulong);
4377             }
4378             break;
4379         case 'V':
4380             while (len-- > 0) {
4381                 fromstr = NEXTFROM;
4382                 aulong = SvUV(fromstr);
4383 #ifdef HAS_HTOVL
4384                 aulong = htovl(aulong);
4385 #endif
4386                 CAT32(cat, &aulong);
4387             }
4388             break;
4389         case 'L':
4390             while (len-- > 0) {
4391                 fromstr = NEXTFROM;
4392                 aulong = SvUV(fromstr);
4393                 CAT32(cat, &aulong);
4394             }
4395             break;
4396         case 'l':
4397             while (len-- > 0) {
4398                 fromstr = NEXTFROM;
4399                 along = SvIV(fromstr);
4400                 CAT32(cat, &along);
4401             }
4402             break;
4403 #ifdef HAS_QUAD
4404         case 'Q':
4405             while (len-- > 0) {
4406                 fromstr = NEXTFROM;
4407                 auquad = (unsigned Quad_t)SvIV(fromstr);
4408                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4409             }
4410             break;
4411         case 'q':
4412             while (len-- > 0) {
4413                 fromstr = NEXTFROM;
4414                 aquad = (Quad_t)SvIV(fromstr);
4415                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4416             }
4417             break;
4418 #endif /* HAS_QUAD */
4419         case 'P':
4420             len = 1;            /* assume SV is correct length */
4421             /* FALL THROUGH */
4422         case 'p':
4423             while (len-- > 0) {
4424                 fromstr = NEXTFROM;
4425                 if (fromstr == &PL_sv_undef)
4426                     aptr = NULL;
4427                 else {
4428                     /* XXX better yet, could spirit away the string to
4429                      * a safe spot and hang on to it until the result
4430                      * of pack() (and all copies of the result) are
4431                      * gone.
4432                      */
4433                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4434                         warner(WARN_UNSAFE,
4435                                 "Attempt to pack pointer to temporary value");
4436                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4437                         aptr = SvPV(fromstr,PL_na);
4438                     else
4439                         aptr = SvPV_force(fromstr,PL_na);
4440                 }
4441                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4442             }
4443             break;
4444         case 'u':
4445             fromstr = NEXTFROM;
4446             aptr = SvPV(fromstr, fromlen);
4447             SvGROW(cat, fromlen * 4 / 3);
4448             if (len <= 1)
4449                 len = 45;
4450             else
4451                 len = len / 3 * 3;
4452             while (fromlen > 0) {
4453                 I32 todo;
4454
4455                 if (fromlen > len)
4456                     todo = len;
4457                 else
4458                     todo = fromlen;
4459                 doencodes(cat, aptr, todo);
4460                 fromlen -= todo;
4461                 aptr += todo;
4462             }
4463             break;
4464         }
4465     }
4466     SvSETMAGIC(cat);
4467     SP = ORIGMARK;
4468     PUSHs(cat);
4469     RETURN;
4470 }
4471 #undef NEXTFROM
4472
4473
4474 PP(pp_split)
4475 {
4476     djSP; dTARG;
4477     AV *ary;
4478     register I32 limit = POPi;                  /* note, negative is forever */
4479     SV *sv = POPs;
4480     STRLEN len;
4481     register char *s = SvPV(sv, len);
4482     char *strend = s + len;
4483     register PMOP *pm;
4484     register REGEXP *rx;
4485     register SV *dstr;
4486     register char *m;
4487     I32 iters = 0;
4488     I32 maxiters = (strend - s) + 10;
4489     I32 i;
4490     char *orig;
4491     I32 origlimit = limit;
4492     I32 realarray = 0;
4493     I32 base;
4494     AV *oldstack = PL_curstack;
4495     I32 gimme = GIMME_V;
4496     I32 oldsave = PL_savestack_ix;
4497     I32 make_mortal = 1;
4498     MAGIC *mg = (MAGIC *) NULL;
4499
4500 #ifdef DEBUGGING
4501     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4502 #else
4503     pm = (PMOP*)POPs;
4504 #endif
4505     if (!pm || !s)
4506         DIE("panic: do_split");
4507     rx = pm->op_pmregexp;
4508
4509     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4510              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4511
4512     if (pm->op_pmreplroot)
4513         ary = GvAVn((GV*)pm->op_pmreplroot);
4514     else if (gimme != G_ARRAY)
4515 #ifdef USE_THREADS
4516         ary = (AV*)PL_curpad[0];
4517 #else
4518         ary = GvAVn(PL_defgv);
4519 #endif /* USE_THREADS */
4520     else
4521         ary = Nullav;
4522     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4523         realarray = 1;
4524         PUTBACK;
4525         av_extend(ary,0);
4526         av_clear(ary);
4527         SPAGAIN;
4528         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4529             PUSHMARK(SP);
4530             XPUSHs(mg->mg_obj);
4531         }
4532         else {
4533             if (!AvREAL(ary)) {
4534                 AvREAL_on(ary);
4535                 for (i = AvFILLp(ary); i >= 0; i--)
4536                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4537             }
4538             /* temporarily switch stacks */
4539             SWITCHSTACK(PL_curstack, ary);
4540             make_mortal = 0;
4541         }
4542     }
4543     base = SP - PL_stack_base;
4544     orig = s;
4545     if (pm->op_pmflags & PMf_SKIPWHITE) {
4546         if (pm->op_pmflags & PMf_LOCALE) {
4547             while (isSPACE_LC(*s))
4548                 s++;
4549         }
4550         else {
4551             while (isSPACE(*s))
4552                 s++;
4553         }
4554     }
4555     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4556         SAVEINT(PL_multiline);
4557         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4558     }
4559
4560     if (!limit)
4561         limit = maxiters + 2;
4562     if (pm->op_pmflags & PMf_WHITE) {
4563         while (--limit) {
4564             m = s;
4565             while (m < strend &&
4566                    !((pm->op_pmflags & PMf_LOCALE)
4567                      ? isSPACE_LC(*m) : isSPACE(*m)))
4568                 ++m;
4569             if (m >= strend)
4570                 break;
4571
4572             dstr = NEWSV(30, m-s);
4573             sv_setpvn(dstr, s, m-s);
4574             if (make_mortal)
4575                 sv_2mortal(dstr);
4576             XPUSHs(dstr);
4577
4578             s = m + 1;
4579             while (s < strend &&
4580                    ((pm->op_pmflags & PMf_LOCALE)
4581                     ? isSPACE_LC(*s) : isSPACE(*s)))
4582                 ++s;
4583         }
4584     }
4585     else if (strEQ("^", rx->precomp)) {
4586         while (--limit) {
4587             /*SUPPRESS 530*/
4588             for (m = s; m < strend && *m != '\n'; m++) ;
4589             m++;
4590             if (m >= strend)
4591                 break;
4592             dstr = NEWSV(30, m-s);
4593             sv_setpvn(dstr, s, m-s);
4594             if (make_mortal)
4595                 sv_2mortal(dstr);
4596             XPUSHs(dstr);
4597             s = m;
4598         }
4599     }
4600     else if (rx->check_substr && !rx->nparens
4601              && (rx->reganch & ROPT_CHECK_ALL)
4602              && !(rx->reganch & ROPT_ANCH)) {
4603         i = SvCUR(rx->check_substr);
4604         if (i == 1 && !SvTAIL(rx->check_substr)) {
4605             i = *SvPVX(rx->check_substr);
4606             while (--limit) {
4607                 /*SUPPRESS 530*/
4608                 for (m = s; m < strend && *m != i; m++) ;
4609                 if (m >= strend)
4610                     break;
4611                 dstr = NEWSV(30, m-s);
4612                 sv_setpvn(dstr, s, m-s);
4613                 if (make_mortal)
4614                     sv_2mortal(dstr);
4615                 XPUSHs(dstr);
4616                 s = m + 1;
4617             }
4618         }
4619         else {
4620 #ifndef lint
4621             while (s < strend && --limit &&
4622               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4623                     rx->check_substr, 0)) )
4624 #endif
4625             {
4626                 dstr = NEWSV(31, m-s);
4627                 sv_setpvn(dstr, s, m-s);
4628                 if (make_mortal)
4629                     sv_2mortal(dstr);
4630                 XPUSHs(dstr);
4631                 s = m + i;
4632             }
4633         }
4634     }
4635     else {
4636         maxiters += (strend - s) * rx->nparens;
4637         while (s < strend && --limit &&
4638                CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4639         {
4640             TAINT_IF(RX_MATCH_TAINTED(rx));
4641             if (rx->subbase
4642               && rx->subbase != orig) {
4643                 m = s;
4644                 s = orig;
4645                 orig = rx->subbase;
4646                 s = orig + (m - s);
4647                 strend = s + (strend - m);
4648             }
4649             m = rx->startp[0];
4650             dstr = NEWSV(32, m-s);
4651             sv_setpvn(dstr, s, m-s);
4652             if (make_mortal)
4653                 sv_2mortal(dstr);
4654             XPUSHs(dstr);
4655             if (rx->nparens) {
4656                 for (i = 1; i <= rx->nparens; i++) {
4657                     s = rx->startp[i];
4658                     m = rx->endp[i];
4659                     if (m && s) {
4660                         dstr = NEWSV(33, m-s);
4661                         sv_setpvn(dstr, s, m-s);
4662                     }
4663                     else
4664                         dstr = NEWSV(33, 0);
4665                     if (make_mortal)
4666                         sv_2mortal(dstr);
4667                     XPUSHs(dstr);
4668                 }
4669             }
4670             s = rx->endp[0];
4671         }
4672     }
4673
4674     LEAVE_SCOPE(oldsave);
4675     iters = (SP - PL_stack_base) - base;
4676     if (iters > maxiters)
4677         DIE("Split loop");
4678
4679     /* keep field after final delim? */
4680     if (s < strend || (iters && origlimit)) {
4681         dstr = NEWSV(34, strend-s);
4682         sv_setpvn(dstr, s, strend-s);
4683         if (make_mortal)
4684             sv_2mortal(dstr);
4685         XPUSHs(dstr);
4686         iters++;
4687     }
4688     else if (!origlimit) {
4689         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4690             iters--, SP--;
4691     }
4692
4693     if (realarray) {
4694         if (!mg) {
4695             SWITCHSTACK(ary, oldstack);
4696             if (SvSMAGICAL(ary)) {
4697                 PUTBACK;
4698                 mg_set((SV*)ary);
4699                 SPAGAIN;
4700             }
4701             if (gimme == G_ARRAY) {
4702                 EXTEND(SP, iters);
4703                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4704                 SP += iters;
4705                 RETURN;
4706             }
4707         }
4708         else {
4709             PUTBACK;
4710             ENTER;
4711             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4712             LEAVE;
4713             SPAGAIN;
4714             if (gimme == G_ARRAY) {
4715                 /* EXTEND should not be needed - we just popped them */
4716                 EXTEND(SP, iters);
4717                 for (i=0; i < iters; i++) {
4718                     SV **svp = av_fetch(ary, i, FALSE);
4719                     PUSHs((svp) ? *svp : &PL_sv_undef);
4720                 }
4721                 RETURN;
4722             }
4723         }
4724     }
4725     else {
4726         if (gimme == G_ARRAY)
4727             RETURN;
4728     }
4729     if (iters || !pm->op_pmreplroot) {
4730         GETTARGET;
4731         PUSHi(iters);
4732         RETURN;
4733     }
4734     RETPUSHUNDEF;
4735 }
4736
4737 #ifdef USE_THREADS
4738 void
4739 unlock_condpair(void *svv)
4740 {
4741     dTHR;
4742     MAGIC *mg = mg_find((SV*)svv, 'm');
4743
4744     if (!mg)
4745         croak("panic: unlock_condpair unlocking non-mutex");
4746     MUTEX_LOCK(MgMUTEXP(mg));
4747     if (MgOWNER(mg) != thr)
4748         croak("panic: unlock_condpair unlocking mutex that we don't own");
4749     MgOWNER(mg) = 0;
4750     COND_SIGNAL(MgOWNERCONDP(mg));
4751     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4752                           (unsigned long)thr, (unsigned long)svv);)
4753     MUTEX_UNLOCK(MgMUTEXP(mg));
4754 }
4755 #endif /* USE_THREADS */
4756
4757 PP(pp_lock)
4758 {
4759     djSP;
4760     dTOPss;
4761     SV *retsv = sv;
4762 #ifdef USE_THREADS
4763     MAGIC *mg;
4764
4765     if (SvROK(sv))
4766         sv = SvRV(sv);
4767
4768     mg = condpair_magic(sv);
4769     MUTEX_LOCK(MgMUTEXP(mg));
4770     if (MgOWNER(mg) == thr)
4771         MUTEX_UNLOCK(MgMUTEXP(mg));
4772     else {
4773         while (MgOWNER(mg))
4774             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4775         MgOWNER(mg) = thr;
4776         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4777                               (unsigned long)thr, (unsigned long)sv);)
4778         MUTEX_UNLOCK(MgMUTEXP(mg));
4779         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4780         save_destructor(unlock_condpair, sv);
4781     }
4782 #endif /* USE_THREADS */
4783     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4784         || SvTYPE(retsv) == SVt_PVCV) {
4785         retsv = refto(retsv);
4786     }
4787     SETs(retsv);
4788     RETURN;
4789 }
4790
4791 PP(pp_threadsv)
4792 {
4793     djSP;
4794 #ifdef USE_THREADS
4795     EXTEND(SP, 1);
4796     if (PL_op->op_private & OPpLVAL_INTRO)
4797         PUSHs(*save_threadsv(PL_op->op_targ));
4798     else
4799         PUSHs(THREADSV(PL_op->op_targ));
4800     RETURN;
4801 #else
4802     DIE("tried to access per-thread data in non-threaded perl");
4803 #endif /* USE_THREADS */
4804 }