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