pp.c

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