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