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