pp.c

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