contrib/perl5/pp.c

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