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