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