pp.c

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