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, 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 PP(pp_unpack)
2912 {
2913     djSP;
2914     dPOPPOPssrl;
2915     SV **oldsp = SP;
2916     I32 gimme = GIMME_V;
2917     SV *sv;
2918     STRLEN llen;
2919     STRLEN rlen;
2920     register char *pat = SvPV(left, llen);
2921     register char *s = SvPV(right, rlen);
2922     char *strend = s + rlen;
2923     char *strbeg = s;
2924     register char *patend = pat + llen;
2925     I32 datumtype;
2926     register I32 len;
2927     register I32 bits;
2928
2929     /* These must not be in registers: */
2930     I16 ashort;
2931     int aint;
2932     I32 along;
2933 #ifdef HAS_QUAD
2934     Quad_t aquad;
2935 #endif
2936     U16 aushort;
2937     unsigned int auint;
2938     U32 aulong;
2939 #ifdef HAS_QUAD
2940     unsigned Quad_t auquad;
2941 #endif
2942     char *aptr;
2943     float afloat;
2944     double adouble;
2945     I32 checksum = 0;
2946     register U32 culong;
2947     double cdouble;
2948     static char* bitcount = 0;
2949     int commas = 0;
2950
2951     if (gimme != G_ARRAY) {             /* arrange to do first one only */
2952         /*SUPPRESS 530*/
2953         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2954         if (strchr("aAbBhHP", *patend) || *pat == '%') {
2955             patend++;
2956             while (isDIGIT(*patend) || *patend == '*')
2957                 patend++;
2958         }
2959         else
2960             patend++;
2961     }
2962     while (pat < patend) {
2963       reparse:
2964         datumtype = *pat++ & 0xFF;
2965         if (isSPACE(datumtype))
2966             continue;
2967         if (pat >= patend)
2968             len = 1;
2969         else if (*pat == '*') {
2970             len = strend - strbeg;      /* long enough */
2971             pat++;
2972         }
2973         else if (isDIGIT(*pat)) {
2974             len = *pat++ - '0';
2975             while (isDIGIT(*pat))
2976                 len = (len * 10) + (*pat++ - '0');
2977         }
2978         else
2979             len = (datumtype != '@');
2980         switch(datumtype) {
2981         default:
2982             croak("Invalid type in unpack: '%c'", (int)datumtype);
2983         case ',': /* grandfather in commas but with a warning */
2984             if (commas++ == 0 && PL_dowarn)
2985                 warn("Invalid type in unpack: '%c'", (int)datumtype);
2986             break;
2987         case '%':
2988             if (len == 1 && pat[-1] != '1')
2989                 len = 16;
2990             checksum = len;
2991             culong = 0;
2992             cdouble = 0;
2993             if (pat < patend)
2994                 goto reparse;
2995             break;
2996         case '@':
2997             if (len > strend - strbeg)
2998                 DIE("@ outside of string");
2999             s = strbeg + len;
3000             break;
3001         case 'X':
3002             if (len > s - strbeg)
3003                 DIE("X outside of string");
3004             s -= len;
3005             break;
3006         case 'x':
3007             if (len > strend - s)
3008                 DIE("x outside of string");
3009             s += len;
3010             break;
3011         case 'A':
3012         case 'a':
3013             if (len > strend - s)
3014                 len = strend - s;
3015             if (checksum)
3016                 goto uchar_checksum;
3017             sv = NEWSV(35, len);
3018             sv_setpvn(sv, s, len);
3019             s += len;
3020             if (datumtype == 'A') {
3021                 aptr = s;       /* borrow register */
3022                 s = SvPVX(sv) + len - 1;
3023                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3024                     s--;
3025                 *++s = '\0';
3026                 SvCUR_set(sv, s - SvPVX(sv));
3027                 s = aptr;       /* unborrow register */
3028             }
3029             XPUSHs(sv_2mortal(sv));
3030             break;
3031         case 'B':
3032         case 'b':
3033             if (pat[-1] == '*' || len > (strend - s) * 8)
3034                 len = (strend - s) * 8;
3035             if (checksum) {
3036                 if (!bitcount) {
3037                     Newz(601, bitcount, 256, char);
3038                     for (bits = 1; bits < 256; bits++) {
3039                         if (bits & 1)   bitcount[bits]++;
3040                         if (bits & 2)   bitcount[bits]++;
3041                         if (bits & 4)   bitcount[bits]++;
3042                         if (bits & 8)   bitcount[bits]++;
3043                         if (bits & 16)  bitcount[bits]++;
3044                         if (bits & 32)  bitcount[bits]++;
3045                         if (bits & 64)  bitcount[bits]++;
3046                         if (bits & 128) bitcount[bits]++;
3047                     }
3048                 }
3049                 while (len >= 8) {
3050                     culong += bitcount[*(unsigned char*)s++];
3051                     len -= 8;
3052                 }
3053                 if (len) {
3054                     bits = *s;
3055                     if (datumtype == 'b') {
3056                         while (len-- > 0) {
3057                             if (bits & 1) culong++;
3058                             bits >>= 1;
3059                         }
3060                     }
3061                     else {
3062                         while (len-- > 0) {
3063                             if (bits & 128) culong++;
3064                             bits <<= 1;
3065                         }
3066                     }
3067                 }
3068                 break;
3069             }
3070             sv = NEWSV(35, len + 1);
3071             SvCUR_set(sv, len);
3072             SvPOK_on(sv);
3073             aptr = pat;                 /* borrow register */
3074             pat = SvPVX(sv);
3075             if (datumtype == 'b') {
3076                 aint = len;
3077                 for (len = 0; len < aint; len++) {
3078                     if (len & 7)                /*SUPPRESS 595*/
3079                         bits >>= 1;
3080                     else
3081                         bits = *s++;
3082                     *pat++ = '0' + (bits & 1);
3083                 }
3084             }
3085             else {
3086                 aint = len;
3087                 for (len = 0; len < aint; len++) {
3088                     if (len & 7)
3089                         bits <<= 1;
3090                     else
3091                         bits = *s++;
3092                     *pat++ = '0' + ((bits & 128) != 0);
3093                 }
3094             }
3095             *pat = '\0';
3096             pat = aptr;                 /* unborrow register */
3097             XPUSHs(sv_2mortal(sv));
3098             break;
3099         case 'H':
3100         case 'h':
3101             if (pat[-1] == '*' || len > (strend - s) * 2)
3102                 len = (strend - s) * 2;
3103             sv = NEWSV(35, len + 1);
3104             SvCUR_set(sv, len);
3105             SvPOK_on(sv);
3106             aptr = pat;                 /* borrow register */
3107             pat = SvPVX(sv);
3108             if (datumtype == 'h') {
3109                 aint = len;
3110                 for (len = 0; len < aint; len++) {
3111                     if (len & 1)
3112                         bits >>= 4;
3113                     else
3114                         bits = *s++;
3115                     *pat++ = PL_hexdigit[bits & 15];
3116                 }
3117             }
3118             else {
3119                 aint = len;
3120                 for (len = 0; len < aint; len++) {
3121                     if (len & 1)
3122                         bits <<= 4;
3123                     else
3124                         bits = *s++;
3125                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3126                 }
3127             }
3128             *pat = '\0';
3129             pat = aptr;                 /* unborrow register */
3130             XPUSHs(sv_2mortal(sv));
3131             break;
3132         case 'c':
3133             if (len > strend - s)
3134                 len = strend - s;
3135             if (checksum) {
3136                 while (len-- > 0) {
3137                     aint = *s++;
3138                     if (aint >= 128)    /* fake up signed chars */
3139                         aint -= 256;
3140                     culong += aint;
3141                 }
3142             }
3143             else {
3144                 EXTEND(SP, len);
3145                 EXTEND_MORTAL(len);
3146                 while (len-- > 0) {
3147                     aint = *s++;
3148                     if (aint >= 128)    /* fake up signed chars */
3149                         aint -= 256;
3150                     sv = NEWSV(36, 0);
3151                     sv_setiv(sv, (IV)aint);
3152                     PUSHs(sv_2mortal(sv));
3153                 }
3154             }
3155             break;
3156         case 'C':
3157             if (len > strend - s)
3158                 len = strend - s;
3159             if (checksum) {
3160               uchar_checksum:
3161                 while (len-- > 0) {
3162                     auint = *s++ & 255;
3163                     culong += auint;
3164                 }
3165             }
3166             else {
3167                 EXTEND(SP, len);
3168                 EXTEND_MORTAL(len);
3169                 while (len-- > 0) {
3170                     auint = *s++ & 255;
3171                     sv = NEWSV(37, 0);
3172                     sv_setiv(sv, (IV)auint);
3173                     PUSHs(sv_2mortal(sv));
3174                 }
3175             }
3176             break;
3177         case 's':
3178             along = (strend - s) / SIZE16;
3179             if (len > along)
3180                 len = along;
3181             if (checksum) {
3182                 while (len-- > 0) {
3183                     COPY16(s, &ashort);
3184                     s += SIZE16;
3185                     culong += ashort;
3186                 }
3187             }
3188             else {
3189                 EXTEND(SP, len);
3190                 EXTEND_MORTAL(len);
3191                 while (len-- > 0) {
3192                     COPY16(s, &ashort);
3193                     s += SIZE16;
3194                     sv = NEWSV(38, 0);
3195                     sv_setiv(sv, (IV)ashort);
3196                     PUSHs(sv_2mortal(sv));
3197                 }
3198             }
3199             break;
3200         case 'v':
3201         case 'n':
3202         case 'S':
3203             along = (strend - s) / SIZE16;
3204             if (len > along)
3205                 len = along;
3206             if (checksum) {
3207                 while (len-- > 0) {
3208                     COPY16(s, &aushort);
3209                     s += SIZE16;
3210 #ifdef HAS_NTOHS
3211                     if (datumtype == 'n')
3212                         aushort = PerlSock_ntohs(aushort);
3213 #endif
3214 #ifdef HAS_VTOHS
3215                     if (datumtype == 'v')
3216                         aushort = vtohs(aushort);
3217 #endif
3218                     culong += aushort;
3219                 }
3220             }
3221             else {
3222                 EXTEND(SP, len);
3223                 EXTEND_MORTAL(len);
3224                 while (len-- > 0) {
3225                     COPY16(s, &aushort);
3226                     s += SIZE16;
3227                     sv = NEWSV(39, 0);
3228 #ifdef HAS_NTOHS
3229                     if (datumtype == 'n')
3230                         aushort = PerlSock_ntohs(aushort);
3231 #endif
3232 #ifdef HAS_VTOHS
3233                     if (datumtype == 'v')
3234                         aushort = vtohs(aushort);
3235 #endif
3236                     sv_setiv(sv, (IV)aushort);
3237                     PUSHs(sv_2mortal(sv));
3238                 }
3239             }
3240             break;
3241         case 'i':
3242             along = (strend - s) / sizeof(int);
3243             if (len > along)
3244                 len = along;
3245             if (checksum) {
3246                 while (len-- > 0) {
3247                     Copy(s, &aint, 1, int);
3248                     s += sizeof(int);
3249                     if (checksum > 32)
3250                         cdouble += (double)aint;
3251                     else
3252                         culong += aint;
3253                 }
3254             }
3255             else {
3256                 EXTEND(SP, len);
3257                 EXTEND_MORTAL(len);
3258                 while (len-- > 0) {
3259                     Copy(s, &aint, 1, int);
3260                     s += sizeof(int);
3261                     sv = NEWSV(40, 0);
3262 #ifdef __osf__
3263                     /* Without the dummy below unpack("i", pack("i",-1))
3264                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3265                      * cc with optimization turned on */
3266                     (aint) ?
3267                         sv_setiv(sv, (IV)aint) :
3268 #endif
3269                     sv_setiv(sv, (IV)aint);
3270                     PUSHs(sv_2mortal(sv));
3271                 }
3272             }
3273             break;
3274         case 'I':
3275             along = (strend - s) / sizeof(unsigned int);
3276             if (len > along)
3277                 len = along;
3278             if (checksum) {
3279                 while (len-- > 0) {
3280                     Copy(s, &auint, 1, unsigned int);
3281                     s += sizeof(unsigned int);
3282                     if (checksum > 32)
3283                         cdouble += (double)auint;
3284                     else
3285                         culong += auint;
3286                 }
3287             }
3288             else {
3289                 EXTEND(SP, len);
3290                 EXTEND_MORTAL(len);
3291                 while (len-- > 0) {
3292                     Copy(s, &auint, 1, unsigned int);
3293                     s += sizeof(unsigned int);
3294                     sv = NEWSV(41, 0);
3295                     sv_setuv(sv, (UV)auint);
3296                     PUSHs(sv_2mortal(sv));
3297                 }
3298             }
3299             break;
3300         case 'l':
3301             along = (strend - s) / SIZE32;
3302             if (len > along)
3303                 len = along;
3304             if (checksum) {
3305                 while (len-- > 0) {
3306                     COPY32(s, &along);
3307                     s += SIZE32;
3308                     if (checksum > 32)
3309                         cdouble += (double)along;
3310                     else
3311                         culong += along;
3312                 }
3313             }
3314             else {
3315                 EXTEND(SP, len);
3316                 EXTEND_MORTAL(len);
3317                 while (len-- > 0) {
3318                     COPY32(s, &along);
3319                     s += SIZE32;
3320                     sv = NEWSV(42, 0);
3321                     sv_setiv(sv, (IV)along);
3322                     PUSHs(sv_2mortal(sv));
3323                 }
3324             }
3325             break;
3326         case 'V':
3327         case 'N':
3328         case 'L':
3329             along = (strend - s) / SIZE32;
3330             if (len > along)
3331                 len = along;
3332             if (checksum) {
3333                 while (len-- > 0) {
3334                     COPY32(s, &aulong);
3335                     s += SIZE32;
3336 #ifdef HAS_NTOHL
3337                     if (datumtype == 'N')
3338                         aulong = PerlSock_ntohl(aulong);
3339 #endif
3340 #ifdef HAS_VTOHL
3341                     if (datumtype == 'V')
3342                         aulong = vtohl(aulong);
3343 #endif
3344                     if (checksum > 32)
3345                         cdouble += (double)aulong;
3346                     else
3347                         culong += aulong;
3348                 }
3349             }
3350             else {
3351                 EXTEND(SP, len);
3352                 EXTEND_MORTAL(len);
3353                 while (len-- > 0) {
3354                     COPY32(s, &aulong);
3355                     s += SIZE32;
3356 #ifdef HAS_NTOHL
3357                     if (datumtype == 'N')
3358                         aulong = PerlSock_ntohl(aulong);
3359 #endif
3360 #ifdef HAS_VTOHL
3361                     if (datumtype == 'V')
3362                         aulong = vtohl(aulong);
3363 #endif
3364                     sv = NEWSV(43, 0);
3365                     sv_setuv(sv, (UV)aulong);
3366                     PUSHs(sv_2mortal(sv));
3367                 }
3368             }
3369             break;
3370         case 'p':
3371             along = (strend - s) / sizeof(char*);
3372             if (len > along)
3373                 len = along;
3374             EXTEND(SP, len);
3375             EXTEND_MORTAL(len);
3376             while (len-- > 0) {
3377                 if (sizeof(char*) > strend - s)
3378                     break;
3379                 else {
3380                     Copy(s, &aptr, 1, char*);
3381                     s += sizeof(char*);
3382                 }
3383                 sv = NEWSV(44, 0);
3384                 if (aptr)
3385                     sv_setpv(sv, aptr);
3386                 PUSHs(sv_2mortal(sv));
3387             }
3388             break;
3389         case 'w':
3390             EXTEND(SP, len);
3391             EXTEND_MORTAL(len);
3392             {
3393                 UV auv = 0;
3394                 U32 bytes = 0;
3395
3396                 while ((len > 0) && (s < strend)) {
3397                     auv = (auv << 7) | (*s & 0x7f);
3398                     if (!(*s++ & 0x80)) {
3399                         bytes = 0;
3400                         sv = NEWSV(40, 0);
3401                         sv_setuv(sv, auv);
3402                         PUSHs(sv_2mortal(sv));
3403                         len--;
3404                         auv = 0;
3405                     }
3406                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3407                         char *t;
3408
3409                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3410                         while (s < strend) {
3411                             sv = mul128(sv, *s & 0x7f);
3412                             if (!(*s++ & 0x80)) {
3413                                 bytes = 0;
3414                                 break;
3415                             }
3416                         }
3417                         t = SvPV(sv, PL_na);
3418                         while (*t == '0')
3419                             t++;
3420                         sv_chop(sv, t);
3421                         PUSHs(sv_2mortal(sv));
3422                         len--;
3423                         auv = 0;
3424                     }
3425                 }
3426                 if ((s >= strend) && bytes)
3427                     croak("Unterminated compressed integer");
3428             }
3429             break;
3430         case 'P':
3431             EXTEND(SP, 1);
3432             if (sizeof(char*) > strend - s)
3433                 break;
3434             else {
3435                 Copy(s, &aptr, 1, char*);
3436                 s += sizeof(char*);
3437             }
3438             sv = NEWSV(44, 0);
3439             if (aptr)
3440                 sv_setpvn(sv, aptr, len);
3441             PUSHs(sv_2mortal(sv));
3442             break;
3443 #ifdef HAS_QUAD
3444         case 'q':
3445             along = (strend - s) / sizeof(Quad_t);
3446             if (len > along)
3447                 len = along;
3448             EXTEND(SP, len);
3449             EXTEND_MORTAL(len);
3450             while (len-- > 0) {
3451                 if (s + sizeof(Quad_t) > strend)
3452                     aquad = 0;
3453                 else {
3454                     Copy(s, &aquad, 1, Quad_t);
3455                     s += sizeof(Quad_t);
3456                 }
3457                 sv = NEWSV(42, 0);
3458                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3459                     sv_setiv(sv, (IV)aquad);
3460                 else
3461                     sv_setnv(sv, (double)aquad);
3462                 PUSHs(sv_2mortal(sv));
3463             }
3464             break;
3465         case 'Q':
3466             along = (strend - s) / sizeof(Quad_t);
3467             if (len > along)
3468                 len = along;
3469             EXTEND(SP, len);
3470             EXTEND_MORTAL(len);
3471             while (len-- > 0) {
3472                 if (s + sizeof(unsigned Quad_t) > strend)
3473                     auquad = 0;
3474                 else {
3475                     Copy(s, &auquad, 1, unsigned Quad_t);
3476                     s += sizeof(unsigned Quad_t);
3477                 }
3478                 sv = NEWSV(43, 0);
3479                 if (auquad <= UV_MAX)
3480                     sv_setuv(sv, (UV)auquad);
3481                 else
3482                     sv_setnv(sv, (double)auquad);
3483                 PUSHs(sv_2mortal(sv));
3484             }
3485             break;
3486 #endif
3487         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3488         case 'f':
3489         case 'F':
3490             along = (strend - s) / sizeof(float);
3491             if (len > along)
3492                 len = along;
3493             if (checksum) {
3494                 while (len-- > 0) {
3495                     Copy(s, &afloat, 1, float);
3496                     s += sizeof(float);
3497                     cdouble += afloat;
3498                 }
3499             }
3500             else {
3501                 EXTEND(SP, len);
3502                 EXTEND_MORTAL(len);
3503                 while (len-- > 0) {
3504                     Copy(s, &afloat, 1, float);
3505                     s += sizeof(float);
3506                     sv = NEWSV(47, 0);
3507                     sv_setnv(sv, (double)afloat);
3508                     PUSHs(sv_2mortal(sv));
3509                 }
3510             }
3511             break;
3512         case 'd':
3513         case 'D':
3514             along = (strend - s) / sizeof(double);
3515             if (len > along)
3516                 len = along;
3517             if (checksum) {
3518                 while (len-- > 0) {
3519                     Copy(s, &adouble, 1, double);
3520                     s += sizeof(double);
3521                     cdouble += adouble;
3522                 }
3523             }
3524             else {
3525                 EXTEND(SP, len);
3526                 EXTEND_MORTAL(len);
3527                 while (len-- > 0) {
3528                     Copy(s, &adouble, 1, double);
3529                     s += sizeof(double);
3530                     sv = NEWSV(48, 0);
3531                     sv_setnv(sv, (double)adouble);
3532                     PUSHs(sv_2mortal(sv));
3533                 }
3534             }
3535             break;
3536         case 'u':
3537             along = (strend - s) * 3 / 4;
3538             sv = NEWSV(42, along);
3539             if (along)
3540                 SvPOK_on(sv);
3541             while (s < strend && *s > ' ' && *s < 'a') {
3542                 I32 a, b, c, d;
3543                 char hunk[4];
3544
3545                 hunk[3] = '\0';
3546                 len = (*s++ - ' ') & 077;
3547                 while (len > 0) {
3548                     if (s < strend && *s >= ' ')
3549                         a = (*s++ - ' ') & 077;
3550                     else
3551                         a = 0;
3552                     if (s < strend && *s >= ' ')
3553                         b = (*s++ - ' ') & 077;
3554                     else
3555                         b = 0;
3556                     if (s < strend && *s >= ' ')
3557                         c = (*s++ - ' ') & 077;
3558                     else
3559                         c = 0;
3560                     if (s < strend && *s >= ' ')
3561                         d = (*s++ - ' ') & 077;
3562                     else
3563                         d = 0;
3564                     hunk[0] = (a << 2) | (b >> 4);
3565                     hunk[1] = (b << 4) | (c >> 2);
3566                     hunk[2] = (c << 6) | d;
3567                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3568                     len -= 3;
3569                 }
3570                 if (*s == '\n')
3571                     s++;
3572                 else if (s[1] == '\n')          /* possible checksum byte */
3573                     s += 2;
3574             }
3575             XPUSHs(sv_2mortal(sv));
3576             break;
3577         }
3578         if (checksum) {
3579             sv = NEWSV(42, 0);
3580             if (strchr("fFdD", datumtype) ||
3581               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3582                 double trouble;
3583
3584                 adouble = 1.0;
3585                 while (checksum >= 16) {
3586                     checksum -= 16;
3587                     adouble *= 65536.0;
3588                 }
3589                 while (checksum >= 4) {
3590                     checksum -= 4;
3591                     adouble *= 16.0;
3592                 }
3593                 while (checksum--)
3594                     adouble *= 2.0;
3595                 along = (1 << checksum) - 1;
3596                 while (cdouble < 0.0)
3597                     cdouble += adouble;
3598                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3599                 sv_setnv(sv, cdouble);
3600             }
3601             else {
3602                 if (checksum < 32) {
3603                     aulong = (1 << checksum) - 1;
3604                     culong &= aulong;
3605                 }
3606                 sv_setuv(sv, (UV)culong);
3607             }
3608             XPUSHs(sv_2mortal(sv));
3609             checksum = 0;
3610         }
3611     }
3612     if (SP == oldsp && gimme == G_SCALAR)
3613         PUSHs(&PL_sv_undef);
3614     RETURN;
3615 }
3616
3617 STATIC void
3618 doencodes(register SV *sv, register char *s, register I32 len)
3619 {
3620     char hunk[5];
3621
3622     *hunk = len + ' ';
3623     sv_catpvn(sv, hunk, 1);
3624     hunk[4] = '\0';
3625     while (len > 0) {
3626         hunk[0] = ' ' + (077 & (*s >> 2));
3627         hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3628         hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3629         hunk[3] = ' ' + (077 & (s[2] & 077));
3630         sv_catpvn(sv, hunk, 4);
3631         s += 3;
3632         len -= 3;
3633     }
3634     for (s = SvPVX(sv); *s; s++) {
3635         if (*s == ' ')
3636             *s = '`';
3637     }
3638     sv_catpvn(sv, "\n", 1);
3639 }
3640
3641 STATIC SV      *
3642 is_an_int(char *s, STRLEN l)
3643 {
3644   SV             *result = newSVpv("", l);
3645   char           *result_c = SvPV(result, PL_na);       /* convenience */
3646   char           *out = result_c;
3647   bool            skip = 1;
3648   bool            ignore = 0;
3649
3650   while (*s) {
3651     switch (*s) {
3652     case ' ':
3653       break;
3654     case '+':
3655       if (!skip) {
3656         SvREFCNT_dec(result);
3657         return (NULL);
3658       }
3659       break;
3660     case '0':
3661     case '1':
3662     case '2':
3663     case '3':
3664     case '4':
3665     case '5':
3666     case '6':
3667     case '7':
3668     case '8':
3669     case '9':
3670       skip = 0;
3671       if (!ignore) {
3672         *(out++) = *s;
3673       }
3674       break;
3675     case '.':
3676       ignore = 1;
3677       break;
3678     default:
3679       SvREFCNT_dec(result);
3680       return (NULL);
3681     }
3682     s++;
3683   }
3684   *(out++) = '\0';
3685   SvCUR_set(result, out - result_c);
3686   return (result);
3687 }
3688
3689 STATIC int
3690 div128(SV *pnum, bool *done)
3691                                             /* must be '\0' terminated */
3692
3693 {
3694   STRLEN          len;
3695   char           *s = SvPV(pnum, len);
3696   int             m = 0;
3697   int             r = 0;
3698   char           *t = s;
3699
3700   *done = 1;
3701   while (*t) {
3702     int             i;
3703
3704     i = m * 10 + (*t - '0');
3705     m = i & 0x7F;
3706     r = (i >> 7);               /* r < 10 */
3707     if (r) {
3708       *done = 0;
3709     }
3710     *(t++) = '0' + r;
3711   }
3712   *(t++) = '\0';
3713   SvCUR_set(pnum, (STRLEN) (t - s));
3714   return (m);
3715 }
3716
3717
3718 PP(pp_pack)
3719 {
3720     djSP; dMARK; dORIGMARK; dTARGET;
3721     register SV *cat = TARG;
3722     register I32 items;
3723     STRLEN fromlen;
3724     register char *pat = SvPVx(*++MARK, fromlen);
3725     register char *patend = pat + fromlen;
3726     register I32 len;
3727     I32 datumtype;
3728     SV *fromstr;
3729     /*SUPPRESS 442*/
3730     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3731     static char *space10 = "          ";
3732
3733     /* These must not be in registers: */
3734     char achar;
3735     I16 ashort;
3736     int aint;
3737     unsigned int auint;
3738     I32 along;
3739     U32 aulong;
3740 #ifdef HAS_QUAD
3741     Quad_t aquad;
3742     unsigned Quad_t auquad;
3743 #endif
3744     char *aptr;
3745     float afloat;
3746     double adouble;
3747     int commas = 0;
3748
3749     items = SP - MARK;
3750     MARK++;
3751     sv_setpvn(cat, "", 0);
3752     while (pat < patend) {
3753 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3754         datumtype = *pat++ & 0xFF;
3755         if (isSPACE(datumtype))
3756             continue;
3757         if (*pat == '*') {
3758             len = strchr("@Xxu", datumtype) ? 0 : items;
3759             pat++;
3760         }
3761         else if (isDIGIT(*pat)) {
3762             len = *pat++ - '0';
3763             while (isDIGIT(*pat))
3764                 len = (len * 10) + (*pat++ - '0');
3765         }
3766         else
3767             len = 1;
3768         switch(datumtype) {
3769         default:
3770             croak("Invalid type in pack: '%c'", (int)datumtype);
3771         case ',': /* grandfather in commas but with a warning */
3772             if (commas++ == 0 && PL_dowarn)
3773                 warn("Invalid type in pack: '%c'", (int)datumtype);
3774             break;
3775         case '%':
3776             DIE("%% may only be used in unpack");
3777         case '@':
3778             len -= SvCUR(cat);
3779             if (len > 0)
3780                 goto grow;
3781             len = -len;
3782             if (len > 0)
3783                 goto shrink;
3784             break;
3785         case 'X':
3786           shrink:
3787             if (SvCUR(cat) < len)
3788                 DIE("X outside of string");
3789             SvCUR(cat) -= len;
3790             *SvEND(cat) = '\0';
3791             break;
3792         case 'x':
3793           grow:
3794             while (len >= 10) {
3795                 sv_catpvn(cat, null10, 10);
3796                 len -= 10;
3797             }
3798             sv_catpvn(cat, null10, len);
3799             break;
3800         case 'A':
3801         case 'a':
3802             fromstr = NEXTFROM;
3803             aptr = SvPV(fromstr, fromlen);
3804             if (pat[-1] == '*')
3805                 len = fromlen;
3806             if (fromlen > len)
3807                 sv_catpvn(cat, aptr, len);
3808             else {
3809                 sv_catpvn(cat, aptr, fromlen);
3810                 len -= fromlen;
3811                 if (datumtype == 'A') {
3812                     while (len >= 10) {
3813                         sv_catpvn(cat, space10, 10);
3814                         len -= 10;
3815                     }
3816                     sv_catpvn(cat, space10, len);
3817                 }
3818                 else {
3819                     while (len >= 10) {
3820                         sv_catpvn(cat, null10, 10);
3821                         len -= 10;
3822                     }
3823                     sv_catpvn(cat, null10, len);
3824                 }
3825             }
3826             break;
3827         case 'B':
3828         case 'b':
3829             {
3830                 char *savepat = pat;
3831                 I32 saveitems;
3832
3833                 fromstr = NEXTFROM;
3834                 saveitems = items;
3835                 aptr = SvPV(fromstr, fromlen);
3836                 if (pat[-1] == '*')
3837                     len = fromlen;
3838                 pat = aptr;
3839                 aint = SvCUR(cat);
3840                 SvCUR(cat) += (len+7)/8;
3841                 SvGROW(cat, SvCUR(cat) + 1);
3842                 aptr = SvPVX(cat) + aint;
3843                 if (len > fromlen)
3844                     len = fromlen;
3845                 aint = len;
3846                 items = 0;
3847                 if (datumtype == 'B') {
3848                     for (len = 0; len++ < aint;) {
3849                         items |= *pat++ & 1;
3850                         if (len & 7)
3851                             items <<= 1;
3852                         else {
3853                             *aptr++ = items & 0xff;
3854                             items = 0;
3855                         }
3856                     }
3857                 }
3858                 else {
3859                     for (len = 0; len++ < aint;) {
3860                         if (*pat++ & 1)
3861                             items |= 128;
3862                         if (len & 7)
3863                             items >>= 1;
3864                         else {
3865                             *aptr++ = items & 0xff;
3866                             items = 0;
3867                         }
3868                     }
3869                 }
3870                 if (aint & 7) {
3871                     if (datumtype == 'B')
3872                         items <<= 7 - (aint & 7);
3873                     else
3874                         items >>= 7 - (aint & 7);
3875                     *aptr++ = items & 0xff;
3876                 }
3877                 pat = SvPVX(cat) + SvCUR(cat);
3878                 while (aptr <= pat)
3879                     *aptr++ = '\0';
3880
3881                 pat = savepat;
3882                 items = saveitems;
3883             }
3884             break;
3885         case 'H':
3886         case 'h':
3887             {
3888                 char *savepat = pat;
3889                 I32 saveitems;
3890
3891                 fromstr = NEXTFROM;
3892                 saveitems = items;
3893                 aptr = SvPV(fromstr, fromlen);
3894                 if (pat[-1] == '*')
3895                     len = fromlen;
3896                 pat = aptr;
3897                 aint = SvCUR(cat);
3898                 SvCUR(cat) += (len+1)/2;
3899                 SvGROW(cat, SvCUR(cat) + 1);
3900                 aptr = SvPVX(cat) + aint;
3901                 if (len > fromlen)
3902                     len = fromlen;
3903                 aint = len;
3904                 items = 0;
3905                 if (datumtype == 'H') {
3906                     for (len = 0; len++ < aint;) {
3907                         if (isALPHA(*pat))
3908                             items |= ((*pat++ & 15) + 9) & 15;
3909                         else
3910                             items |= *pat++ & 15;
3911                         if (len & 1)
3912                             items <<= 4;
3913                         else {
3914                             *aptr++ = items & 0xff;
3915                             items = 0;
3916                         }
3917                     }
3918                 }
3919                 else {
3920                     for (len = 0; len++ < aint;) {
3921                         if (isALPHA(*pat))
3922                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3923                         else
3924                             items |= (*pat++ & 15) << 4;
3925                         if (len & 1)
3926                             items >>= 4;
3927                         else {
3928                             *aptr++ = items & 0xff;
3929                             items = 0;
3930                         }
3931                     }
3932                 }
3933                 if (aint & 1)
3934                     *aptr++ = items & 0xff;
3935                 pat = SvPVX(cat) + SvCUR(cat);
3936                 while (aptr <= pat)
3937                     *aptr++ = '\0';
3938
3939                 pat = savepat;
3940                 items = saveitems;
3941             }
3942             break;
3943         case 'C':
3944         case 'c':
3945             while (len-- > 0) {
3946                 fromstr = NEXTFROM;
3947                 aint = SvIV(fromstr);
3948                 achar = aint;
3949                 sv_catpvn(cat, &achar, sizeof(char));
3950             }
3951             break;
3952         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3953         case 'f':
3954         case 'F':
3955             while (len-- > 0) {
3956                 fromstr = NEXTFROM;
3957                 afloat = (float)SvNV(fromstr);
3958                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3959             }
3960             break;
3961         case 'd':
3962         case 'D':
3963             while (len-- > 0) {
3964                 fromstr = NEXTFROM;
3965                 adouble = (double)SvNV(fromstr);
3966                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3967             }
3968             break;
3969         case 'n':
3970             while (len-- > 0) {
3971                 fromstr = NEXTFROM;
3972                 ashort = (I16)SvIV(fromstr);
3973 #ifdef HAS_HTONS
3974                 ashort = PerlSock_htons(ashort);
3975 #endif
3976                 CAT16(cat, &ashort);
3977             }
3978             break;
3979         case 'v':
3980             while (len-- > 0) {
3981                 fromstr = NEXTFROM;
3982                 ashort = (I16)SvIV(fromstr);
3983 #ifdef HAS_HTOVS
3984                 ashort = htovs(ashort);
3985 #endif
3986                 CAT16(cat, &ashort);
3987             }
3988             break;
3989         case 'S':
3990         case 's':
3991             while (len-- > 0) {
3992                 fromstr = NEXTFROM;
3993                 ashort = (I16)SvIV(fromstr);
3994                 CAT16(cat, &ashort);
3995             }
3996             break;
3997         case 'I':
3998             while (len-- > 0) {
3999                 fromstr = NEXTFROM;
4000                 auint = SvUV(fromstr);
4001                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4002             }
4003             break;
4004         case 'w':
4005             while (len-- > 0) {
4006                 fromstr = NEXTFROM;
4007                 adouble = floor(SvNV(fromstr));
4008
4009                 if (adouble < 0)
4010                     croak("Cannot compress negative numbers");
4011
4012                 if (
4013 #ifdef BW_BITS
4014                     adouble <= BW_MASK
4015 #else
4016 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4017                     adouble <= UV_MAX_cxux
4018 #else
4019                     adouble <= UV_MAX
4020 #endif
4021 #endif
4022                     )
4023                 {
4024                     char   buf[1 + sizeof(UV)];
4025                     char  *in = buf + sizeof(buf);
4026                     UV     auv = U_V(adouble);;
4027
4028                     do {
4029                         *--in = (auv & 0x7f) | 0x80;
4030                         auv >>= 7;
4031                     } while (auv);
4032                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4033                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4034                 }
4035                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4036                     char           *from, *result, *in;
4037                     SV             *norm;
4038                     STRLEN          len;
4039                     bool            done;
4040
4041                     /* Copy string and check for compliance */
4042                     from = SvPV(fromstr, len);
4043                     if ((norm = is_an_int(from, len)) == NULL)
4044                         croak("can compress only unsigned integer");
4045
4046                     New('w', result, len, char);
4047                     in = result + len;
4048                     done = FALSE;
4049                     while (!done)
4050                         *--in = div128(norm, &done) | 0x80;
4051                     result[len - 1] &= 0x7F; /* clear continue bit */
4052                     sv_catpvn(cat, in, (result + len) - in);
4053                     Safefree(result);
4054                     SvREFCNT_dec(norm); /* free norm */
4055                 }
4056                 else if (SvNOKp(fromstr)) {
4057                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4058                     char  *in = buf + sizeof(buf);
4059
4060                     do {
4061                         double next = floor(adouble / 128);
4062                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4063                         if (--in < buf)  /* this cannot happen ;-) */
4064                             croak ("Cannot compress integer");
4065                         adouble = next;
4066                     } while (adouble > 0);
4067                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4068                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4069                 }
4070                 else
4071                     croak("Cannot compress non integer");
4072             }
4073             break;
4074         case 'i':
4075             while (len-- > 0) {
4076                 fromstr = NEXTFROM;
4077                 aint = SvIV(fromstr);
4078                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4079             }
4080             break;
4081         case 'N':
4082             while (len-- > 0) {
4083                 fromstr = NEXTFROM;
4084                 aulong = SvUV(fromstr);
4085 #ifdef HAS_HTONL
4086                 aulong = PerlSock_htonl(aulong);
4087 #endif
4088                 CAT32(cat, &aulong);
4089             }
4090             break;
4091         case 'V':
4092             while (len-- > 0) {
4093                 fromstr = NEXTFROM;
4094                 aulong = SvUV(fromstr);
4095 #ifdef HAS_HTOVL
4096                 aulong = htovl(aulong);
4097 #endif
4098                 CAT32(cat, &aulong);
4099             }
4100             break;
4101         case 'L':
4102             while (len-- > 0) {
4103                 fromstr = NEXTFROM;
4104                 aulong = SvUV(fromstr);
4105                 CAT32(cat, &aulong);
4106             }
4107             break;
4108         case 'l':
4109             while (len-- > 0) {
4110                 fromstr = NEXTFROM;
4111                 along = SvIV(fromstr);
4112                 CAT32(cat, &along);
4113             }
4114             break;
4115 #ifdef HAS_QUAD
4116         case 'Q':
4117             while (len-- > 0) {
4118                 fromstr = NEXTFROM;
4119                 auquad = (unsigned Quad_t)SvIV(fromstr);
4120                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4121             }
4122             break;
4123         case 'q':
4124             while (len-- > 0) {
4125                 fromstr = NEXTFROM;
4126                 aquad = (Quad_t)SvIV(fromstr);
4127                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4128             }
4129             break;
4130 #endif /* HAS_QUAD */
4131         case 'P':
4132             len = 1;            /* assume SV is correct length */
4133             /* FALL THROUGH */
4134         case 'p':
4135             while (len-- > 0) {
4136                 fromstr = NEXTFROM;
4137                 if (fromstr == &PL_sv_undef)
4138                     aptr = NULL;
4139                 else {
4140                     /* XXX better yet, could spirit away the string to
4141                      * a safe spot and hang on to it until the result
4142                      * of pack() (and all copies of the result) are
4143                      * gone.
4144                      */
4145                     if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4146                         warn("Attempt to pack pointer to temporary value");
4147                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4148                         aptr = SvPV(fromstr,PL_na);
4149                     else
4150                         aptr = SvPV_force(fromstr,PL_na);
4151                 }
4152                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4153             }
4154             break;
4155         case 'u':
4156             fromstr = NEXTFROM;
4157             aptr = SvPV(fromstr, fromlen);
4158             SvGROW(cat, fromlen * 4 / 3);
4159             if (len <= 1)
4160                 len = 45;
4161             else
4162                 len = len / 3 * 3;
4163             while (fromlen > 0) {
4164                 I32 todo;
4165
4166                 if (fromlen > len)
4167                     todo = len;
4168                 else
4169                     todo = fromlen;
4170                 doencodes(cat, aptr, todo);
4171                 fromlen -= todo;
4172                 aptr += todo;
4173             }
4174             break;
4175         }
4176     }
4177     SvSETMAGIC(cat);
4178     SP = ORIGMARK;
4179     PUSHs(cat);
4180     RETURN;
4181 }
4182 #undef NEXTFROM
4183
4184
4185 PP(pp_split)
4186 {
4187     djSP; dTARG;
4188     AV *ary;
4189     register I32 limit = POPi;                  /* note, negative is forever */
4190     SV *sv = POPs;
4191     STRLEN len;
4192     register char *s = SvPV(sv, len);
4193     char *strend = s + len;
4194     register PMOP *pm;
4195     register REGEXP *rx;
4196     register SV *dstr;
4197     register char *m;
4198     I32 iters = 0;
4199     I32 maxiters = (strend - s) + 10;
4200     I32 i;
4201     char *orig;
4202     I32 origlimit = limit;
4203     I32 realarray = 0;
4204     I32 base;
4205     AV *oldstack = PL_curstack;
4206     I32 gimme = GIMME_V;
4207     I32 oldsave = PL_savestack_ix;
4208     I32 make_mortal = 1;
4209     MAGIC *mg = (MAGIC *) NULL;
4210
4211 #ifdef DEBUGGING
4212     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4213 #else
4214     pm = (PMOP*)POPs;
4215 #endif
4216     if (!pm || !s)
4217         DIE("panic: do_split");
4218     rx = pm->op_pmregexp;
4219
4220     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4221              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4222
4223     if (pm->op_pmreplroot)
4224         ary = GvAVn((GV*)pm->op_pmreplroot);
4225     else if (gimme != G_ARRAY)
4226 #ifdef USE_THREADS
4227         ary = (AV*)PL_curpad[0];
4228 #else
4229         ary = GvAVn(PL_defgv);
4230 #endif /* USE_THREADS */
4231     else
4232         ary = Nullav;
4233     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4234         realarray = 1;
4235         PUTBACK;
4236         av_extend(ary,0);
4237         av_clear(ary);
4238         SPAGAIN;
4239         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4240             PUSHMARK(SP);
4241             XPUSHs(mg->mg_obj);
4242         }
4243         else {
4244             if (!AvREAL(ary)) {
4245                 AvREAL_on(ary);
4246                 for (i = AvFILLp(ary); i >= 0; i--)
4247                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4248             }
4249             /* temporarily switch stacks */
4250             SWITCHSTACK(PL_curstack, ary);
4251             make_mortal = 0;
4252         }
4253     }
4254     base = SP - PL_stack_base;
4255     orig = s;
4256     if (pm->op_pmflags & PMf_SKIPWHITE) {
4257         if (pm->op_pmflags & PMf_LOCALE) {
4258             while (isSPACE_LC(*s))
4259                 s++;
4260         }
4261         else {
4262             while (isSPACE(*s))
4263                 s++;
4264         }
4265     }
4266     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4267         SAVEINT(PL_multiline);
4268         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4269     }
4270
4271     if (!limit)
4272         limit = maxiters + 2;
4273     if (pm->op_pmflags & PMf_WHITE) {
4274         while (--limit) {
4275             m = s;
4276             while (m < strend &&
4277                    !((pm->op_pmflags & PMf_LOCALE)
4278                      ? isSPACE_LC(*m) : isSPACE(*m)))
4279                 ++m;
4280             if (m >= strend)
4281                 break;
4282
4283             dstr = NEWSV(30, m-s);
4284             sv_setpvn(dstr, s, m-s);
4285             if (make_mortal)
4286                 sv_2mortal(dstr);
4287             XPUSHs(dstr);
4288
4289             s = m + 1;
4290             while (s < strend &&
4291                    ((pm->op_pmflags & PMf_LOCALE)
4292                     ? isSPACE_LC(*s) : isSPACE(*s)))
4293                 ++s;
4294         }
4295     }
4296     else if (strEQ("^", rx->precomp)) {
4297         while (--limit) {
4298             /*SUPPRESS 530*/
4299             for (m = s; m < strend && *m != '\n'; m++) ;
4300             m++;
4301             if (m >= strend)
4302                 break;
4303             dstr = NEWSV(30, m-s);
4304             sv_setpvn(dstr, s, m-s);
4305             if (make_mortal)
4306                 sv_2mortal(dstr);
4307             XPUSHs(dstr);
4308             s = m;
4309         }
4310     }
4311     else if (rx->check_substr && !rx->nparens
4312              && (rx->reganch & ROPT_CHECK_ALL)
4313              && !(rx->reganch & ROPT_ANCH)) {
4314         i = SvCUR(rx->check_substr);
4315         if (i == 1 && !SvTAIL(rx->check_substr)) {
4316             i = *SvPVX(rx->check_substr);
4317             while (--limit) {
4318                 /*SUPPRESS 530*/
4319                 for (m = s; m < strend && *m != i; m++) ;
4320                 if (m >= strend)
4321                     break;
4322                 dstr = NEWSV(30, m-s);
4323                 sv_setpvn(dstr, s, m-s);
4324                 if (make_mortal)
4325                     sv_2mortal(dstr);
4326                 XPUSHs(dstr);
4327                 s = m + 1;
4328             }
4329         }
4330         else {
4331 #ifndef lint
4332             while (s < strend && --limit &&
4333               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4334                     rx->check_substr, 0)) )
4335 #endif
4336             {
4337                 dstr = NEWSV(31, m-s);
4338                 sv_setpvn(dstr, s, m-s);
4339                 if (make_mortal)
4340                     sv_2mortal(dstr);
4341                 XPUSHs(dstr);
4342                 s = m + i;
4343             }
4344         }
4345     }
4346     else {
4347         maxiters += (strend - s) * rx->nparens;
4348         while (s < strend && --limit &&
4349                CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4350         {
4351             TAINT_IF(RX_MATCH_TAINTED(rx));
4352             if (rx->subbase
4353               && rx->subbase != orig) {
4354                 m = s;
4355                 s = orig;
4356                 orig = rx->subbase;
4357                 s = orig + (m - s);
4358                 strend = s + (strend - m);
4359             }
4360             m = rx->startp[0];
4361             dstr = NEWSV(32, m-s);
4362             sv_setpvn(dstr, s, m-s);
4363             if (make_mortal)
4364                 sv_2mortal(dstr);
4365             XPUSHs(dstr);
4366             if (rx->nparens) {
4367                 for (i = 1; i <= rx->nparens; i++) {
4368                     s = rx->startp[i];
4369                     m = rx->endp[i];
4370                     if (m && s) {
4371                         dstr = NEWSV(33, m-s);
4372                         sv_setpvn(dstr, s, m-s);
4373                     }
4374                     else
4375                         dstr = NEWSV(33, 0);
4376                     if (make_mortal)
4377                         sv_2mortal(dstr);
4378                     XPUSHs(dstr);
4379                 }
4380             }
4381             s = rx->endp[0];
4382         }
4383     }
4384
4385     LEAVE_SCOPE(oldsave);
4386     iters = (SP - PL_stack_base) - base;
4387     if (iters > maxiters)
4388         DIE("Split loop");
4389
4390     /* keep field after final delim? */
4391     if (s < strend || (iters && origlimit)) {
4392         dstr = NEWSV(34, strend-s);
4393         sv_setpvn(dstr, s, strend-s);
4394         if (make_mortal)
4395             sv_2mortal(dstr);
4396         XPUSHs(dstr);
4397         iters++;
4398     }
4399     else if (!origlimit) {
4400         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4401             iters--, SP--;
4402     }
4403
4404     if (realarray) {
4405         if (!mg) {
4406             SWITCHSTACK(ary, oldstack);
4407             if (SvSMAGICAL(ary)) {
4408                 PUTBACK;
4409                 mg_set((SV*)ary);
4410                 SPAGAIN;
4411             }
4412             if (gimme == G_ARRAY) {
4413                 EXTEND(SP, iters);
4414                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4415                 SP += iters;
4416                 RETURN;
4417             }
4418         }
4419         else {
4420             PUTBACK;
4421             ENTER;
4422             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4423             LEAVE;
4424             SPAGAIN;
4425             if (gimme == G_ARRAY) {
4426                 /* EXTEND should not be needed - we just popped them */
4427                 EXTEND(SP, iters);
4428                 for (i=0; i < iters; i++) {
4429                     SV **svp = av_fetch(ary, i, FALSE);
4430                     PUSHs((svp) ? *svp : &PL_sv_undef);
4431                 }
4432                 RETURN;
4433             }
4434         }
4435     }
4436     else {
4437         if (gimme == G_ARRAY)
4438             RETURN;
4439     }
4440     if (iters || !pm->op_pmreplroot) {
4441         GETTARGET;
4442         PUSHi(iters);
4443         RETURN;
4444     }
4445     RETPUSHUNDEF;
4446 }
4447
4448 #ifdef USE_THREADS
4449 void
4450 unlock_condpair(void *svv)
4451 {
4452     dTHR;
4453     MAGIC *mg = mg_find((SV*)svv, 'm');
4454
4455     if (!mg)
4456         croak("panic: unlock_condpair unlocking non-mutex");
4457     MUTEX_LOCK(MgMUTEXP(mg));
4458     if (MgOWNER(mg) != thr)
4459         croak("panic: unlock_condpair unlocking mutex that we don't own");
4460     MgOWNER(mg) = 0;
4461     COND_SIGNAL(MgOWNERCONDP(mg));
4462     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4463                           (unsigned long)thr, (unsigned long)svv);)
4464     MUTEX_UNLOCK(MgMUTEXP(mg));
4465 }
4466 #endif /* USE_THREADS */
4467
4468 PP(pp_lock)
4469 {
4470     djSP;
4471     dTOPss;
4472     SV *retsv = sv;
4473 #ifdef USE_THREADS
4474     MAGIC *mg;
4475
4476     if (SvROK(sv))
4477         sv = SvRV(sv);
4478
4479     mg = condpair_magic(sv);
4480     MUTEX_LOCK(MgMUTEXP(mg));
4481     if (MgOWNER(mg) == thr)
4482         MUTEX_UNLOCK(MgMUTEXP(mg));
4483     else {
4484         while (MgOWNER(mg))
4485             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4486         MgOWNER(mg) = thr;
4487         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4488                               (unsigned long)thr, (unsigned long)sv);)
4489         MUTEX_UNLOCK(MgMUTEXP(mg));
4490         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4491         save_destructor(unlock_condpair, sv);
4492     }
4493 #endif /* USE_THREADS */
4494     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4495         || SvTYPE(retsv) == SVt_PVCV) {
4496         retsv = refto(retsv);
4497     }
4498     SETs(retsv);
4499     RETURN;
4500 }
4501
4502 PP(pp_threadsv)
4503 {
4504     djSP;
4505 #ifdef USE_THREADS
4506     EXTEND(SP, 1);
4507     if (PL_op->op_private & OPpLVAL_INTRO)
4508         PUSHs(*save_threadsv(PL_op->op_targ));
4509     else
4510         PUSHs(THREADSV(PL_op->op_targ));
4511     RETURN;
4512 #else
4513     DIE("tried to access per-thread data in non-threaded perl");
4514 #endif /* USE_THREADS */
4515 }