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("Can't 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             (void)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         else
2833             ix -= arybase;
2834         if (ix < 0 || ix >= max)
2835             *lelem = &PL_sv_undef;
2836         else {
2837             is_something_there = TRUE;
2838             if (!(*lelem = firstrelem[ix]))
2839                 *lelem = &PL_sv_undef;
2840         }
2841     }
2842     if (is_something_there)
2843         SP = lastlelem;
2844     else
2845         SP = firstlelem - 1;
2846     RETURN;
2847 }
2848
2849 PP(pp_anonlist)
2850 {
2851     djSP; dMARK; dORIGMARK;
2852     I32 items = SP - MARK;
2853     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2854     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2855     XPUSHs(av);
2856     RETURN;
2857 }
2858
2859 PP(pp_anonhash)
2860 {
2861     djSP; dMARK; dORIGMARK;
2862     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2863
2864     while (MARK < SP) {
2865         SV* key = *++MARK;
2866         SV *val = NEWSV(46, 0);
2867         if (MARK < SP)
2868             sv_setsv(val, *++MARK);
2869         else if (ckWARN(WARN_UNSAFE))
2870             warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2871         (void)hv_store_ent(hv,key,val,0);
2872     }
2873     SP = ORIGMARK;
2874     XPUSHs((SV*)hv);
2875     RETURN;
2876 }
2877
2878 PP(pp_splice)
2879 {
2880     djSP; dMARK; dORIGMARK;
2881     register AV *ary = (AV*)*++MARK;
2882     register SV **src;
2883     register SV **dst;
2884     register I32 i;
2885     register I32 offset;
2886     register I32 length;
2887     I32 newlen;
2888     I32 after;
2889     I32 diff;
2890     SV **tmparyval = 0;
2891     MAGIC *mg;
2892
2893     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2894         *MARK-- = SvTIED_obj((SV*)ary, mg);
2895         PUSHMARK(MARK);
2896         PUTBACK;
2897         ENTER;
2898         perl_call_method("SPLICE",GIMME_V);
2899         LEAVE;
2900         SPAGAIN;
2901         RETURN;
2902     }
2903
2904     SP++;
2905
2906     if (++MARK < SP) {
2907         offset = i = SvIVx(*MARK);
2908         if (offset < 0)
2909             offset += AvFILLp(ary) + 1;
2910         else
2911             offset -= PL_curcop->cop_arybase;
2912         if (offset < 0)
2913             DIE(PL_no_aelem, i);
2914         if (++MARK < SP) {
2915             length = SvIVx(*MARK++);
2916             if (length < 0) {
2917                 length += AvFILLp(ary) - offset + 1;
2918                 if (length < 0)
2919                     length = 0;
2920             }
2921         }
2922         else
2923             length = AvMAX(ary) + 1;            /* close enough to infinity */
2924     }
2925     else {
2926         offset = 0;
2927         length = AvMAX(ary) + 1;
2928     }
2929     if (offset > AvFILLp(ary) + 1)
2930         offset = AvFILLp(ary) + 1;
2931     after = AvFILLp(ary) + 1 - (offset + length);
2932     if (after < 0) {                            /* not that much array */
2933         length += after;                        /* offset+length now in array */
2934         after = 0;
2935         if (!AvALLOC(ary))
2936             av_extend(ary, 0);
2937     }
2938
2939     /* At this point, MARK .. SP-1 is our new LIST */
2940
2941     newlen = SP - MARK;
2942     diff = newlen - length;
2943     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2944         av_reify(ary);
2945
2946     if (diff < 0) {                             /* shrinking the area */
2947         if (newlen) {
2948             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2949             Copy(MARK, tmparyval, newlen, SV*);
2950         }
2951
2952         MARK = ORIGMARK + 1;
2953         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2954             MEXTEND(MARK, length);
2955             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2956             if (AvREAL(ary)) {
2957                 EXTEND_MORTAL(length);
2958                 for (i = length, dst = MARK; i; i--) {
2959                     sv_2mortal(*dst);   /* free them eventualy */
2960                     dst++;
2961                 }
2962             }
2963             MARK += length - 1;
2964         }
2965         else {
2966             *MARK = AvARRAY(ary)[offset+length-1];
2967             if (AvREAL(ary)) {
2968                 sv_2mortal(*MARK);
2969                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2970                     SvREFCNT_dec(*dst++);       /* free them now */
2971             }
2972         }
2973         AvFILLp(ary) += diff;
2974
2975         /* pull up or down? */
2976
2977         if (offset < after) {                   /* easier to pull up */
2978             if (offset) {                       /* esp. if nothing to pull */
2979                 src = &AvARRAY(ary)[offset-1];
2980                 dst = src - diff;               /* diff is negative */
2981                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2982                     *dst-- = *src--;
2983             }
2984             dst = AvARRAY(ary);
2985             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2986             AvMAX(ary) += diff;
2987         }
2988         else {
2989             if (after) {                        /* anything to pull down? */
2990                 src = AvARRAY(ary) + offset + length;
2991                 dst = src + diff;               /* diff is negative */
2992                 Move(src, dst, after, SV*);
2993             }
2994             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2995                                                 /* avoid later double free */
2996         }
2997         i = -diff;
2998         while (i)
2999             dst[--i] = &PL_sv_undef;
3000
3001         if (newlen) {
3002             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3003               newlen; newlen--) {
3004                 *dst = NEWSV(46, 0);
3005                 sv_setsv(*dst++, *src++);
3006             }
3007             Safefree(tmparyval);
3008         }
3009     }
3010     else {                                      /* no, expanding (or same) */
3011         if (length) {
3012             New(452, tmparyval, length, SV*);   /* so remember deletion */
3013             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3014         }
3015
3016         if (diff > 0) {                         /* expanding */
3017
3018             /* push up or down? */
3019
3020             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3021                 if (offset) {
3022                     src = AvARRAY(ary);
3023                     dst = src - diff;
3024                     Move(src, dst, offset, SV*);
3025                 }
3026                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3027                 AvMAX(ary) += diff;
3028                 AvFILLp(ary) += diff;
3029             }
3030             else {
3031                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3032                     av_extend(ary, AvFILLp(ary) + diff);
3033                 AvFILLp(ary) += diff;
3034
3035                 if (after) {
3036                     dst = AvARRAY(ary) + AvFILLp(ary);
3037                     src = dst - diff;
3038                     for (i = after; i; i--) {
3039                         *dst-- = *src--;
3040                     }
3041                 }
3042             }
3043         }
3044
3045         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3046             *dst = NEWSV(46, 0);
3047             sv_setsv(*dst++, *src++);
3048         }
3049         MARK = ORIGMARK + 1;
3050         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3051             if (length) {
3052                 Copy(tmparyval, MARK, length, SV*);
3053                 if (AvREAL(ary)) {
3054                     EXTEND_MORTAL(length);
3055                     for (i = length, dst = MARK; i; i--) {
3056                         sv_2mortal(*dst);       /* free them eventualy */
3057                         dst++;
3058                     }
3059                 }
3060                 Safefree(tmparyval);
3061             }
3062             MARK += length - 1;
3063         }
3064         else if (length--) {
3065             *MARK = tmparyval[length];
3066             if (AvREAL(ary)) {
3067                 sv_2mortal(*MARK);
3068                 while (length-- > 0)
3069                     SvREFCNT_dec(tmparyval[length]);
3070             }
3071             Safefree(tmparyval);
3072         }
3073         else
3074             *MARK = &PL_sv_undef;
3075     }
3076     SP = MARK;
3077     RETURN;
3078 }
3079
3080 PP(pp_push)
3081 {
3082     djSP; dMARK; dORIGMARK; dTARGET;
3083     register AV *ary = (AV*)*++MARK;
3084     register SV *sv = &PL_sv_undef;
3085     MAGIC *mg;
3086
3087     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3088         *MARK-- = SvTIED_obj((SV*)ary, mg);
3089         PUSHMARK(MARK);
3090         PUTBACK;
3091         ENTER;
3092         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3093         LEAVE;
3094         SPAGAIN;
3095     }
3096     else {
3097         /* Why no pre-extend of ary here ? */
3098         for (++MARK; MARK <= SP; MARK++) {
3099             sv = NEWSV(51, 0);
3100             if (*MARK)
3101                 sv_setsv(sv, *MARK);
3102             av_push(ary, sv);
3103         }
3104     }
3105     SP = ORIGMARK;
3106     PUSHi( AvFILL(ary) + 1 );
3107     RETURN;
3108 }
3109
3110 PP(pp_pop)
3111 {
3112     djSP;
3113     AV *av = (AV*)POPs;
3114     SV *sv = av_pop(av);
3115     if (AvREAL(av))
3116         (void)sv_2mortal(sv);
3117     PUSHs(sv);
3118     RETURN;
3119 }
3120
3121 PP(pp_shift)
3122 {
3123     djSP;
3124     AV *av = (AV*)POPs;
3125     SV *sv = av_shift(av);
3126     EXTEND(SP, 1);
3127     if (!sv)
3128         RETPUSHUNDEF;
3129     if (AvREAL(av))
3130         (void)sv_2mortal(sv);
3131     PUSHs(sv);
3132     RETURN;
3133 }
3134
3135 PP(pp_unshift)
3136 {
3137     djSP; dMARK; dORIGMARK; dTARGET;
3138     register AV *ary = (AV*)*++MARK;
3139     register SV *sv;
3140     register I32 i = 0;
3141     MAGIC *mg;
3142
3143     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3144         *MARK-- = SvTIED_obj((SV*)ary, mg);
3145         PUSHMARK(MARK);
3146         PUTBACK;
3147         ENTER;
3148         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3149         LEAVE;
3150         SPAGAIN;
3151     }
3152     else {
3153         av_unshift(ary, SP - MARK);
3154         while (MARK < SP) {
3155             sv = NEWSV(27, 0);
3156             sv_setsv(sv, *++MARK);
3157             (void)av_store(ary, i++, sv);
3158         }
3159     }
3160     SP = ORIGMARK;
3161     PUSHi( AvFILL(ary) + 1 );
3162     RETURN;
3163 }
3164
3165 PP(pp_reverse)
3166 {
3167     djSP; dMARK;
3168     register SV *tmp;
3169     SV **oldsp = SP;
3170
3171     if (GIMME == G_ARRAY) {
3172         MARK++;
3173         while (MARK < SP) {
3174             tmp = *MARK;
3175             *MARK++ = *SP;
3176             *SP-- = tmp;
3177         }
3178         SP = oldsp;
3179     }
3180     else {
3181         register char *up;
3182         register char *down;
3183         register I32 tmp;
3184         dTARGET;
3185         STRLEN len;
3186
3187         if (SP - MARK > 1)
3188             do_join(TARG, &PL_sv_no, MARK, SP);
3189         else
3190             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3191         up = SvPV_force(TARG, len);
3192         if (len > 1) {
3193             if (IN_UTF8) {      /* first reverse each character */
3194                 U8* s = (U8*)SvPVX(TARG);
3195                 U8* send = (U8*)(s + len);
3196                 while (s < send) {
3197                     if (*s < 0x80) {
3198                         s++;
3199                         continue;
3200                     }
3201                     else {
3202                         up = (char*)s;
3203                         s += UTF8SKIP(s);
3204                         down = (char*)(s - 1);
3205                         if (s > send || !((*down & 0xc0) == 0x80)) {
3206                             warn("Malformed UTF-8 character");
3207                             break;
3208                         }
3209                         while (down > up) {
3210                             tmp = *up;
3211                             *up++ = *down;
3212                             *down-- = tmp;
3213                         }
3214                     }
3215                 }
3216                 up = SvPVX(TARG);
3217             }
3218             down = SvPVX(TARG) + len - 1;
3219             while (down > up) {
3220                 tmp = *up;
3221                 *up++ = *down;
3222                 *down-- = tmp;
3223             }
3224             (void)SvPOK_only(TARG);
3225         }
3226         SP = MARK + 1;
3227         SETTARG;
3228     }
3229     RETURN;
3230 }
3231
3232 STATIC SV      *
3233 mul128(SV *sv, U8 m)
3234 {
3235   STRLEN          len;
3236   char           *s = SvPV(sv, len);
3237   char           *t;
3238   U32             i = 0;
3239
3240   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3241     SV             *tmpNew = newSVpvn("0000000000", 10);
3242
3243     sv_catsv(tmpNew, sv);
3244     SvREFCNT_dec(sv);           /* free old sv */
3245     sv = tmpNew;
3246     s = SvPV(sv, len);
3247   }
3248   t = s + len - 1;
3249   while (!*t)                   /* trailing '\0'? */
3250     t--;
3251   while (t > s) {
3252     i = ((*t - '0') << 7) + m;
3253     *(t--) = '0' + (i % 10);
3254     m = i / 10;
3255   }
3256   return (sv);
3257 }
3258
3259 /* Explosives and implosives. */
3260
3261 #if 'I' == 73 && 'J' == 74
3262 /* On an ASCII/ISO kind of system */
3263 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3264 #else
3265 /*
3266   Some other sort of character set - use memchr() so we don't match
3267   the null byte.
3268  */
3269 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3270 #endif
3271
3272 PP(pp_unpack)
3273 {
3274     djSP;
3275     dPOPPOPssrl;
3276     SV **oldsp = SP;
3277     I32 gimme = GIMME_V;
3278     SV *sv;
3279     STRLEN llen;
3280     STRLEN rlen;
3281     register char *pat = SvPV(left, llen);
3282     register char *s = SvPV(right, rlen);
3283     char *strend = s + rlen;
3284     char *strbeg = s;
3285     register char *patend = pat + llen;
3286     I32 datumtype;
3287     register I32 len;
3288     register I32 bits;
3289
3290     /* These must not be in registers: */
3291     I16 ashort;
3292     int aint;
3293     I32 along;
3294 #ifdef HAS_QUAD
3295     Quad_t aquad;
3296 #endif
3297     U16 aushort;
3298     unsigned int auint;
3299     U32 aulong;
3300 #ifdef HAS_QUAD
3301     Uquad_t auquad;
3302 #endif
3303     char *aptr;
3304     float afloat;
3305     double adouble;
3306     I32 checksum = 0;
3307     register U32 culong;
3308     double cdouble;
3309     int commas = 0;
3310 #ifdef PERL_NATINT_PACK
3311     int natint;         /* native integer */
3312     int unatint;        /* unsigned native integer */
3313 #endif
3314
3315     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3316         /*SUPPRESS 530*/
3317         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3318         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3319             patend++;
3320             while (isDIGIT(*patend) || *patend == '*')
3321                 patend++;
3322         }
3323         else
3324             patend++;
3325     }
3326     while (pat < patend) {
3327       reparse:
3328         datumtype = *pat++ & 0xFF;
3329 #ifdef PERL_NATINT_PACK
3330         natint = 0;
3331 #endif
3332         if (isSPACE(datumtype))
3333             continue;
3334         if (*pat == '!') {
3335             char *natstr = "sSiIlL";
3336
3337             if (strchr(natstr, datumtype)) {
3338 #ifdef PERL_NATINT_PACK
3339                 natint = 1;
3340 #endif
3341                 pat++;
3342             }
3343             else
3344                 croak("'!' allowed only after types %s", natstr);
3345         }
3346         if (pat >= patend)
3347             len = 1;
3348         else if (*pat == '*') {
3349             len = strend - strbeg;      /* long enough */
3350             pat++;
3351         }
3352         else if (isDIGIT(*pat)) {
3353             len = *pat++ - '0';
3354             while (isDIGIT(*pat))
3355                 len = (len * 10) + (*pat++ - '0');
3356         }
3357         else
3358             len = (datumtype != '@');
3359         switch(datumtype) {
3360         default:
3361             croak("Invalid type in unpack: '%c'", (int)datumtype);
3362         case ',': /* grandfather in commas but with a warning */
3363             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3364                 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3365             break;
3366         case '%':
3367             if (len == 1 && pat[-1] != '1')
3368                 len = 16;
3369             checksum = len;
3370             culong = 0;
3371             cdouble = 0;
3372             if (pat < patend)
3373                 goto reparse;
3374             break;
3375         case '@':
3376             if (len > strend - strbeg)
3377                 DIE("@ outside of string");
3378             s = strbeg + len;
3379             break;
3380         case 'X':
3381             if (len > s - strbeg)
3382                 DIE("X outside of string");
3383             s -= len;
3384             break;
3385         case 'x':
3386             if (len > strend - s)
3387                 DIE("x outside of string");
3388             s += len;
3389             break;
3390         case 'A':
3391         case 'Z':
3392         case 'a':
3393             if (len > strend - s)
3394                 len = strend - s;
3395             if (checksum)
3396                 goto uchar_checksum;
3397             sv = NEWSV(35, len);
3398             sv_setpvn(sv, s, len);
3399             s += len;
3400             if (datumtype == 'A' || datumtype == 'Z') {
3401                 aptr = s;       /* borrow register */
3402                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3403                     s = SvPVX(sv);
3404                     while (*s)
3405                         s++;
3406                 }
3407                 else {          /* 'A' strips both nulls and spaces */
3408                     s = SvPVX(sv) + len - 1;
3409                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3410                         s--;
3411                     *++s = '\0';
3412                 }
3413                 SvCUR_set(sv, s - SvPVX(sv));
3414                 s = aptr;       /* unborrow register */
3415             }
3416             XPUSHs(sv_2mortal(sv));
3417             break;
3418         case 'B':
3419         case 'b':
3420             if (pat[-1] == '*' || len > (strend - s) * 8)
3421                 len = (strend - s) * 8;
3422             if (checksum) {
3423                 if (!PL_bitcount) {
3424                     Newz(601, PL_bitcount, 256, char);
3425                     for (bits = 1; bits < 256; bits++) {
3426                         if (bits & 1)   PL_bitcount[bits]++;
3427                         if (bits & 2)   PL_bitcount[bits]++;
3428                         if (bits & 4)   PL_bitcount[bits]++;
3429                         if (bits & 8)   PL_bitcount[bits]++;
3430                         if (bits & 16)  PL_bitcount[bits]++;
3431                         if (bits & 32)  PL_bitcount[bits]++;
3432                         if (bits & 64)  PL_bitcount[bits]++;
3433                         if (bits & 128) PL_bitcount[bits]++;
3434                     }
3435                 }
3436                 while (len >= 8) {
3437                     culong += PL_bitcount[*(unsigned char*)s++];
3438                     len -= 8;
3439                 }
3440                 if (len) {
3441                     bits = *s;
3442                     if (datumtype == 'b') {
3443                         while (len-- > 0) {
3444                             if (bits & 1) culong++;
3445                             bits >>= 1;
3446                         }
3447                     }
3448                     else {
3449                         while (len-- > 0) {
3450                             if (bits & 128) culong++;
3451                             bits <<= 1;
3452                         }
3453                     }
3454                 }
3455                 break;
3456             }
3457             sv = NEWSV(35, len + 1);
3458             SvCUR_set(sv, len);
3459             SvPOK_on(sv);
3460             aptr = pat;                 /* borrow register */
3461             pat = SvPVX(sv);
3462             if (datumtype == 'b') {
3463                 aint = len;
3464                 for (len = 0; len < aint; len++) {
3465                     if (len & 7)                /*SUPPRESS 595*/
3466                         bits >>= 1;
3467                     else
3468                         bits = *s++;
3469                     *pat++ = '0' + (bits & 1);
3470                 }
3471             }
3472             else {
3473                 aint = len;
3474                 for (len = 0; len < aint; len++) {
3475                     if (len & 7)
3476                         bits <<= 1;
3477                     else
3478                         bits = *s++;
3479                     *pat++ = '0' + ((bits & 128) != 0);
3480                 }
3481             }
3482             *pat = '\0';
3483             pat = aptr;                 /* unborrow register */
3484             XPUSHs(sv_2mortal(sv));
3485             break;
3486         case 'H':
3487         case 'h':
3488             if (pat[-1] == '*' || len > (strend - s) * 2)
3489                 len = (strend - s) * 2;
3490             sv = NEWSV(35, len + 1);
3491             SvCUR_set(sv, len);
3492             SvPOK_on(sv);
3493             aptr = pat;                 /* borrow register */
3494             pat = SvPVX(sv);
3495             if (datumtype == 'h') {
3496                 aint = len;
3497                 for (len = 0; len < aint; len++) {
3498                     if (len & 1)
3499                         bits >>= 4;
3500                     else
3501                         bits = *s++;
3502                     *pat++ = PL_hexdigit[bits & 15];
3503                 }
3504             }
3505             else {
3506                 aint = len;
3507                 for (len = 0; len < aint; len++) {
3508                     if (len & 1)
3509                         bits <<= 4;
3510                     else
3511                         bits = *s++;
3512                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3513                 }
3514             }
3515             *pat = '\0';
3516             pat = aptr;                 /* unborrow register */
3517             XPUSHs(sv_2mortal(sv));
3518             break;
3519         case 'c':
3520             if (len > strend - s)
3521                 len = strend - s;
3522             if (checksum) {
3523                 while (len-- > 0) {
3524                     aint = *s++;
3525                     if (aint >= 128)    /* fake up signed chars */
3526                         aint -= 256;
3527                     culong += aint;
3528                 }
3529             }
3530             else {
3531                 EXTEND(SP, len);
3532                 EXTEND_MORTAL(len);
3533                 while (len-- > 0) {
3534                     aint = *s++;
3535                     if (aint >= 128)    /* fake up signed chars */
3536                         aint -= 256;
3537                     sv = NEWSV(36, 0);
3538                     sv_setiv(sv, (IV)aint);
3539                     PUSHs(sv_2mortal(sv));
3540                 }
3541             }
3542             break;
3543         case 'C':
3544             if (len > strend - s)
3545                 len = strend - s;
3546             if (checksum) {
3547               uchar_checksum:
3548                 while (len-- > 0) {
3549                     auint = *s++ & 255;
3550                     culong += auint;
3551                 }
3552             }
3553             else {
3554                 EXTEND(SP, len);
3555                 EXTEND_MORTAL(len);
3556                 while (len-- > 0) {
3557                     auint = *s++ & 255;
3558                     sv = NEWSV(37, 0);
3559                     sv_setiv(sv, (IV)auint);
3560                     PUSHs(sv_2mortal(sv));
3561                 }
3562             }
3563             break;
3564         case 'U':
3565             if (len > strend - s)
3566                 len = strend - s;
3567             if (checksum) {
3568                 while (len-- > 0 && s < strend) {
3569                     auint = utf8_to_uv((U8*)s, &along);
3570                     s += along;
3571                     if (checksum > 32)
3572                         cdouble += (double)auint;
3573                     else
3574                         culong += auint;
3575                 }
3576             }
3577             else {
3578                 EXTEND(SP, len);
3579                 EXTEND_MORTAL(len);
3580                 while (len-- > 0 && s < strend) {
3581                     auint = utf8_to_uv((U8*)s, &along);
3582                     s += along;
3583                     sv = NEWSV(37, 0);
3584                     sv_setuv(sv, (UV)auint);
3585                     PUSHs(sv_2mortal(sv));
3586                 }
3587             }
3588             break;
3589         case 's':
3590 #if SHORTSIZE == SIZE16
3591             along = (strend - s) / SIZE16;
3592 #else
3593             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3594 #endif
3595             if (len > along)
3596                 len = along;
3597             if (checksum) {
3598 #if SHORTSIZE != SIZE16
3599                 if (natint) {
3600                     while (len-- > 0) {
3601                         COPYNN(s, &ashort, sizeof(short));
3602                         s += sizeof(short);
3603                         culong += ashort;
3604
3605                     }
3606                 }
3607                 else
3608 #endif
3609                 {
3610                     while (len-- > 0) {
3611                         COPY16(s, &ashort);
3612 #if SHORTSIZE > SIZE16
3613                         if (ashort > 32767)
3614                           ashort -= 65536;
3615 #endif
3616                         s += SIZE16;
3617                         culong += ashort;
3618                     }
3619                 }
3620             }
3621             else {
3622                 EXTEND(SP, len);
3623                 EXTEND_MORTAL(len);
3624 #if SHORTSIZE != SIZE16
3625                 if (natint) {
3626                     while (len-- > 0) {
3627                         COPYNN(s, &ashort, sizeof(short));
3628                         s += sizeof(short);
3629                         sv = NEWSV(38, 0);
3630                         sv_setiv(sv, (IV)ashort);
3631                         PUSHs(sv_2mortal(sv));
3632                     }
3633                 }
3634                 else
3635 #endif
3636                 {
3637                     while (len-- > 0) {
3638                         COPY16(s, &ashort);
3639 #if SHORTSIZE > SIZE16
3640                         if (ashort > 32767)
3641                           ashort -= 65536;
3642 #endif
3643                         s += SIZE16;
3644                         sv = NEWSV(38, 0);
3645                         sv_setiv(sv, (IV)ashort);
3646                         PUSHs(sv_2mortal(sv));
3647                     }
3648                 }
3649             }
3650             break;
3651         case 'v':
3652         case 'n':
3653         case 'S':
3654 #if SHORTSIZE == SIZE16
3655             along = (strend - s) / SIZE16;
3656 #else
3657             unatint = natint && datumtype == 'S';
3658             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3659 #endif
3660             if (len > along)
3661                 len = along;
3662             if (checksum) {
3663 #if SHORTSIZE != SIZE16
3664                 if (unatint) {
3665                     while (len-- > 0) {
3666                         COPYNN(s, &aushort, sizeof(unsigned short));
3667                         s += sizeof(unsigned short);
3668                         culong += aushort;
3669                     }
3670                 }
3671                 else
3672 #endif
3673                 {
3674                     while (len-- > 0) {
3675                         COPY16(s, &aushort);
3676                         s += SIZE16;
3677 #ifdef HAS_NTOHS
3678                         if (datumtype == 'n')
3679                             aushort = PerlSock_ntohs(aushort);
3680 #endif
3681 #ifdef HAS_VTOHS
3682                         if (datumtype == 'v')
3683                             aushort = vtohs(aushort);
3684 #endif
3685                         culong += aushort;
3686                     }
3687                 }
3688             }
3689             else {
3690                 EXTEND(SP, len);
3691                 EXTEND_MORTAL(len);
3692 #if SHORTSIZE != SIZE16
3693                 if (unatint) {
3694                     while (len-- > 0) {
3695                         COPYNN(s, &aushort, sizeof(unsigned short));
3696                         s += sizeof(unsigned short);
3697                         sv = NEWSV(39, 0);
3698                         sv_setiv(sv, (UV)aushort);
3699                         PUSHs(sv_2mortal(sv));
3700                     }
3701                 }
3702                 else
3703 #endif
3704                 {
3705                     while (len-- > 0) {
3706                         COPY16(s, &aushort);
3707                         s += SIZE16;
3708                         sv = NEWSV(39, 0);
3709 #ifdef HAS_NTOHS
3710                         if (datumtype == 'n')
3711                             aushort = PerlSock_ntohs(aushort);
3712 #endif
3713 #ifdef HAS_VTOHS
3714                         if (datumtype == 'v')
3715                             aushort = vtohs(aushort);
3716 #endif
3717                         sv_setiv(sv, (UV)aushort);
3718                         PUSHs(sv_2mortal(sv));
3719                     }
3720                 }
3721             }
3722             break;
3723         case 'i':
3724             along = (strend - s) / sizeof(int);
3725             if (len > along)
3726                 len = along;
3727             if (checksum) {
3728                 while (len-- > 0) {
3729                     Copy(s, &aint, 1, int);
3730                     s += sizeof(int);
3731                     if (checksum > 32)
3732                         cdouble += (double)aint;
3733                     else
3734                         culong += aint;
3735                 }
3736             }
3737             else {
3738                 EXTEND(SP, len);
3739                 EXTEND_MORTAL(len);
3740                 while (len-- > 0) {
3741                     Copy(s, &aint, 1, int);
3742                     s += sizeof(int);
3743                     sv = NEWSV(40, 0);
3744 #ifdef __osf__
3745                     /* Without the dummy below unpack("i", pack("i",-1))
3746                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3747                      * cc with optimization turned on.
3748                      *
3749                      * The bug was detected in
3750                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3751                      * with optimization (-O4) turned on.
3752                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3753                      * does not have this problem even with -O4.
3754                      *
3755                      * This bug was reported as DECC_BUGS 1431
3756                      * and tracked internally as GEM_BUGS 7775.
3757                      *
3758                      * The bug is fixed in
3759                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3760                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3761                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3762                      * and also in DTK.
3763                      *
3764                      * See also few lines later for the same bug.
3765                      */
3766                     (aint) ?
3767                         sv_setiv(sv, (IV)aint) :
3768 #endif
3769                     sv_setiv(sv, (IV)aint);
3770                     PUSHs(sv_2mortal(sv));
3771                 }
3772             }
3773             break;
3774         case 'I':
3775             along = (strend - s) / sizeof(unsigned int);
3776             if (len > along)
3777                 len = along;
3778             if (checksum) {
3779                 while (len-- > 0) {
3780                     Copy(s, &auint, 1, unsigned int);
3781                     s += sizeof(unsigned int);
3782                     if (checksum > 32)
3783                         cdouble += (double)auint;
3784                     else
3785                         culong += auint;
3786                 }
3787             }
3788             else {
3789                 EXTEND(SP, len);
3790                 EXTEND_MORTAL(len);
3791                 while (len-- > 0) {
3792                     Copy(s, &auint, 1, unsigned int);
3793                     s += sizeof(unsigned int);
3794                     sv = NEWSV(41, 0);
3795 #ifdef __osf__
3796                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3797                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3798                      * See details few lines earlier. */
3799                     (auint) ?
3800                         sv_setuv(sv, (UV)auint) :
3801 #endif
3802                     sv_setuv(sv, (UV)auint);
3803                     PUSHs(sv_2mortal(sv));
3804                 }
3805             }
3806             break;
3807         case 'l':
3808 #if LONGSIZE == SIZE32
3809             along = (strend - s) / SIZE32;
3810 #else
3811             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3812 #endif
3813             if (len > along)
3814                 len = along;
3815             if (checksum) {
3816 #if LONGSIZE != SIZE32
3817                 if (natint) {
3818                     while (len-- > 0) {
3819                         COPYNN(s, &along, sizeof(long));
3820                         s += sizeof(long);
3821                         if (checksum > 32)
3822                             cdouble += (double)along;
3823                         else
3824                             culong += along;
3825                     }
3826                 }
3827                 else
3828 #endif
3829                 {
3830                     while (len-- > 0) {
3831                         COPY32(s, &along);
3832 #if LONGSIZE > SIZE32
3833                         if (along > 2147483647)
3834                           along -= 4294967296;
3835 #endif
3836                         s += SIZE32;
3837                         if (checksum > 32)
3838                             cdouble += (double)along;
3839                         else
3840                             culong += along;
3841                     }
3842                 }
3843             }
3844             else {
3845                 EXTEND(SP, len);
3846                 EXTEND_MORTAL(len);
3847 #if LONGSIZE != SIZE32
3848                 if (natint) {
3849                     while (len-- > 0) {
3850                         COPYNN(s, &along, sizeof(long));
3851                         s += sizeof(long);
3852                         sv = NEWSV(42, 0);
3853                         sv_setiv(sv, (IV)along);
3854                         PUSHs(sv_2mortal(sv));
3855                     }
3856                 }
3857                 else
3858 #endif
3859                 {
3860                     while (len-- > 0) {
3861                         COPY32(s, &along);
3862 #if LONGSIZE > SIZE32
3863                         if (along > 2147483647)
3864                           along -= 4294967296;
3865 #endif
3866                         s += SIZE32;
3867                         sv = NEWSV(42, 0);
3868                         sv_setiv(sv, (IV)along);
3869                         PUSHs(sv_2mortal(sv));
3870                     }
3871                 }
3872             }
3873             break;
3874         case 'V':
3875         case 'N':
3876         case 'L':
3877 #if LONGSIZE == SIZE32
3878             along = (strend - s) / SIZE32;
3879 #else
3880             unatint = natint && datumtype == 'L';
3881             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3882 #endif
3883             if (len > along)
3884                 len = along;
3885             if (checksum) {
3886 #if LONGSIZE != SIZE32
3887                 if (unatint) {
3888                     while (len-- > 0) {
3889                         COPYNN(s, &aulong, sizeof(unsigned long));
3890                         s += sizeof(unsigned long);
3891                         if (checksum > 32)
3892                             cdouble += (double)aulong;
3893                         else
3894                             culong += aulong;
3895                     }
3896                 }
3897                 else
3898 #endif
3899                 {
3900                     while (len-- > 0) {
3901                         COPY32(s, &aulong);
3902                         s += SIZE32;
3903 #ifdef HAS_NTOHL
3904                         if (datumtype == 'N')
3905                             aulong = PerlSock_ntohl(aulong);
3906 #endif
3907 #ifdef HAS_VTOHL
3908                         if (datumtype == 'V')
3909                             aulong = vtohl(aulong);
3910 #endif
3911                         if (checksum > 32)
3912                             cdouble += (double)aulong;
3913                         else
3914                             culong += aulong;
3915                     }
3916                 }
3917             }
3918             else {
3919                 EXTEND(SP, len);
3920                 EXTEND_MORTAL(len);
3921 #if LONGSIZE != SIZE32
3922                 if (unatint) {
3923                     while (len-- > 0) {
3924                         COPYNN(s, &aulong, sizeof(unsigned long));
3925                         s += sizeof(unsigned long);
3926                         sv = NEWSV(43, 0);
3927                         sv_setuv(sv, (UV)aulong);
3928                         PUSHs(sv_2mortal(sv));
3929                     }
3930                 }
3931                 else
3932 #endif
3933                 {
3934                     while (len-- > 0) {
3935                         COPY32(s, &aulong);
3936                         s += SIZE32;
3937 #ifdef HAS_NTOHL
3938                         if (datumtype == 'N')
3939                             aulong = PerlSock_ntohl(aulong);
3940 #endif
3941 #ifdef HAS_VTOHL
3942                         if (datumtype == 'V')
3943                             aulong = vtohl(aulong);
3944 #endif
3945                         sv = NEWSV(43, 0);
3946                         sv_setuv(sv, (UV)aulong);
3947                         PUSHs(sv_2mortal(sv));
3948                     }
3949                 }
3950             }
3951             break;
3952         case 'p':
3953             along = (strend - s) / sizeof(char*);
3954             if (len > along)
3955                 len = along;
3956             EXTEND(SP, len);
3957             EXTEND_MORTAL(len);
3958             while (len-- > 0) {
3959                 if (sizeof(char*) > strend - s)
3960                     break;
3961                 else {
3962                     Copy(s, &aptr, 1, char*);
3963                     s += sizeof(char*);
3964                 }
3965                 sv = NEWSV(44, 0);
3966                 if (aptr)
3967                     sv_setpv(sv, aptr);
3968                 PUSHs(sv_2mortal(sv));
3969             }
3970             break;
3971         case 'w':
3972             EXTEND(SP, len);
3973             EXTEND_MORTAL(len);
3974             {
3975                 UV auv = 0;
3976                 U32 bytes = 0;
3977
3978                 while ((len > 0) && (s < strend)) {
3979                     auv = (auv << 7) | (*s & 0x7f);
3980                     if (!(*s++ & 0x80)) {
3981                         bytes = 0;
3982                         sv = NEWSV(40, 0);
3983                         sv_setuv(sv, auv);
3984                         PUSHs(sv_2mortal(sv));
3985                         len--;
3986                         auv = 0;
3987                     }
3988                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3989                         char *t;
3990                         STRLEN n_a;
3991
3992                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3993                         while (s < strend) {
3994                             sv = mul128(sv, *s & 0x7f);
3995                             if (!(*s++ & 0x80)) {
3996                                 bytes = 0;
3997                                 break;
3998                             }
3999                         }
4000                         t = SvPV(sv, n_a);
4001                         while (*t == '0')
4002                             t++;
4003                         sv_chop(sv, t);
4004                         PUSHs(sv_2mortal(sv));
4005                         len--;
4006                         auv = 0;
4007                     }
4008                 }
4009                 if ((s >= strend) && bytes)
4010                     croak("Unterminated compressed integer");
4011             }
4012             break;
4013         case 'P':
4014             EXTEND(SP, 1);
4015             if (sizeof(char*) > strend - s)
4016                 break;
4017             else {
4018                 Copy(s, &aptr, 1, char*);
4019                 s += sizeof(char*);
4020             }
4021             sv = NEWSV(44, 0);
4022             if (aptr)
4023                 sv_setpvn(sv, aptr, len);
4024             PUSHs(sv_2mortal(sv));
4025             break;
4026 #ifdef HAS_QUAD
4027         case 'q':
4028             along = (strend - s) / sizeof(Quad_t);
4029             if (len > along)
4030                 len = along;
4031             EXTEND(SP, len);
4032             EXTEND_MORTAL(len);
4033             while (len-- > 0) {
4034                 if (s + sizeof(Quad_t) > strend)
4035                     aquad = 0;
4036                 else {
4037                     Copy(s, &aquad, 1, Quad_t);
4038                     s += sizeof(Quad_t);
4039                 }
4040                 sv = NEWSV(42, 0);
4041                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4042                     sv_setiv(sv, (IV)aquad);
4043                 else
4044                     sv_setnv(sv, (double)aquad);
4045                 PUSHs(sv_2mortal(sv));
4046             }
4047             break;
4048         case 'Q':
4049             along = (strend - s) / sizeof(Quad_t);
4050             if (len > along)
4051                 len = along;
4052             EXTEND(SP, len);
4053             EXTEND_MORTAL(len);
4054             while (len-- > 0) {
4055                 if (s + sizeof(Uquad_t) > strend)
4056                     auquad = 0;
4057                 else {
4058                     Copy(s, &auquad, 1, Uquad_t);
4059                     s += sizeof(Uquad_t);
4060                 }
4061                 sv = NEWSV(43, 0);
4062                 if (auquad <= UV_MAX)
4063                     sv_setuv(sv, (UV)auquad);
4064                 else
4065                     sv_setnv(sv, (double)auquad);
4066                 PUSHs(sv_2mortal(sv));
4067             }
4068             break;
4069 #endif
4070         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4071         case 'f':
4072         case 'F':
4073             along = (strend - s) / sizeof(float);
4074             if (len > along)
4075                 len = along;
4076             if (checksum) {
4077                 while (len-- > 0) {
4078                     Copy(s, &afloat, 1, float);
4079                     s += sizeof(float);
4080                     cdouble += afloat;
4081                 }
4082             }
4083             else {
4084                 EXTEND(SP, len);
4085                 EXTEND_MORTAL(len);
4086                 while (len-- > 0) {
4087                     Copy(s, &afloat, 1, float);
4088                     s += sizeof(float);
4089                     sv = NEWSV(47, 0);
4090                     sv_setnv(sv, (double)afloat);
4091                     PUSHs(sv_2mortal(sv));
4092                 }
4093             }
4094             break;
4095         case 'd':
4096         case 'D':
4097             along = (strend - s) / sizeof(double);
4098             if (len > along)
4099                 len = along;
4100             if (checksum) {
4101                 while (len-- > 0) {
4102                     Copy(s, &adouble, 1, double);
4103                     s += sizeof(double);
4104                     cdouble += adouble;
4105                 }
4106             }
4107             else {
4108                 EXTEND(SP, len);
4109                 EXTEND_MORTAL(len);
4110                 while (len-- > 0) {
4111                     Copy(s, &adouble, 1, double);
4112                     s += sizeof(double);
4113                     sv = NEWSV(48, 0);
4114                     sv_setnv(sv, (double)adouble);
4115                     PUSHs(sv_2mortal(sv));
4116                 }
4117             }
4118             break;
4119         case 'u':
4120             /* MKS:
4121              * Initialise the decode mapping.  By using a table driven
4122              * algorithm, the code will be character-set independent
4123              * (and just as fast as doing character arithmetic)
4124              */
4125             if (PL_uudmap['M'] == 0) {
4126                 int i;
4127
4128                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4129                     PL_uudmap[PL_uuemap[i]] = i;
4130                 /*
4131                  * Because ' ' and '`' map to the same value,
4132                  * we need to decode them both the same.
4133                  */
4134                 PL_uudmap[' '] = 0;
4135             }
4136
4137             along = (strend - s) * 3 / 4;
4138             sv = NEWSV(42, along);
4139             if (along)
4140                 SvPOK_on(sv);
4141             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4142                 I32 a, b, c, d;
4143                 char hunk[4];
4144
4145                 hunk[3] = '\0';
4146                 len = PL_uudmap[*s++] & 077;
4147                 while (len > 0) {
4148                     if (s < strend && ISUUCHAR(*s))
4149                         a = PL_uudmap[*s++] & 077;
4150                     else
4151                         a = 0;
4152                     if (s < strend && ISUUCHAR(*s))
4153                         b = PL_uudmap[*s++] & 077;
4154                     else
4155                         b = 0;
4156                     if (s < strend && ISUUCHAR(*s))
4157                         c = PL_uudmap[*s++] & 077;
4158                     else
4159                         c = 0;
4160                     if (s < strend && ISUUCHAR(*s))
4161                         d = PL_uudmap[*s++] & 077;
4162                     else
4163                         d = 0;
4164                     hunk[0] = (a << 2) | (b >> 4);
4165                     hunk[1] = (b << 4) | (c >> 2);
4166                     hunk[2] = (c << 6) | d;
4167                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4168                     len -= 3;
4169                 }
4170                 if (*s == '\n')
4171                     s++;
4172                 else if (s[1] == '\n')          /* possible checksum byte */
4173                     s += 2;
4174             }
4175             XPUSHs(sv_2mortal(sv));
4176             break;
4177         }
4178         if (checksum) {
4179             sv = NEWSV(42, 0);
4180             if (strchr("fFdD", datumtype) ||
4181               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4182                 double trouble;
4183
4184                 adouble = 1.0;
4185                 while (checksum >= 16) {
4186                     checksum -= 16;
4187                     adouble *= 65536.0;
4188                 }
4189                 while (checksum >= 4) {
4190                     checksum -= 4;
4191                     adouble *= 16.0;
4192                 }
4193                 while (checksum--)
4194                     adouble *= 2.0;
4195                 along = (1 << checksum) - 1;
4196                 while (cdouble < 0.0)
4197                     cdouble += adouble;
4198                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4199                 sv_setnv(sv, cdouble);
4200             }
4201             else {
4202                 if (checksum < 32) {
4203                     aulong = (1 << checksum) - 1;
4204                     culong &= aulong;
4205                 }
4206                 sv_setuv(sv, (UV)culong);
4207             }
4208             XPUSHs(sv_2mortal(sv));
4209             checksum = 0;
4210         }
4211     }
4212     if (SP == oldsp && gimme == G_SCALAR)
4213         PUSHs(&PL_sv_undef);
4214     RETURN;
4215 }
4216
4217 STATIC void
4218 doencodes(register SV *sv, register char *s, register I32 len)
4219 {
4220     char hunk[5];
4221
4222     *hunk = PL_uuemap[len];
4223     sv_catpvn(sv, hunk, 1);
4224     hunk[4] = '\0';
4225     while (len > 2) {
4226         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4227         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4228         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4229         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4230         sv_catpvn(sv, hunk, 4);
4231         s += 3;
4232         len -= 3;
4233     }
4234     if (len > 0) {
4235         char r = (len > 1 ? s[1] : '\0');
4236         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4237         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4238         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4239         hunk[3] = PL_uuemap[0];
4240         sv_catpvn(sv, hunk, 4);
4241     }
4242     sv_catpvn(sv, "\n", 1);
4243 }
4244
4245 STATIC SV *
4246 is_an_int(char *s, STRLEN l)
4247 {
4248   STRLEN         n_a;
4249   SV             *result = newSVpvn(s, l);
4250   char           *result_c = SvPV(result, n_a); /* convenience */
4251   char           *out = result_c;
4252   bool            skip = 1;
4253   bool            ignore = 0;
4254
4255   while (*s) {
4256     switch (*s) {
4257     case ' ':
4258       break;
4259     case '+':
4260       if (!skip) {
4261         SvREFCNT_dec(result);
4262         return (NULL);
4263       }
4264       break;
4265     case '0':
4266     case '1':
4267     case '2':
4268     case '3':
4269     case '4':
4270     case '5':
4271     case '6':
4272     case '7':
4273     case '8':
4274     case '9':
4275       skip = 0;
4276       if (!ignore) {
4277         *(out++) = *s;
4278       }
4279       break;
4280     case '.':
4281       ignore = 1;
4282       break;
4283     default:
4284       SvREFCNT_dec(result);
4285       return (NULL);
4286     }
4287     s++;
4288   }
4289   *(out++) = '\0';
4290   SvCUR_set(result, out - result_c);
4291   return (result);
4292 }
4293
4294 STATIC int
4295 div128(SV *pnum, bool *done)
4296                                             /* must be '\0' terminated */
4297
4298 {
4299   STRLEN          len;
4300   char           *s = SvPV(pnum, len);
4301   int             m = 0;
4302   int             r = 0;
4303   char           *t = s;
4304
4305   *done = 1;
4306   while (*t) {
4307     int             i;
4308
4309     i = m * 10 + (*t - '0');
4310     m = i & 0x7F;
4311     r = (i >> 7);               /* r < 10 */
4312     if (r) {
4313       *done = 0;
4314     }
4315     *(t++) = '0' + r;
4316   }
4317   *(t++) = '\0';
4318   SvCUR_set(pnum, (STRLEN) (t - s));
4319   return (m);
4320 }
4321
4322
4323 PP(pp_pack)
4324 {
4325     djSP; dMARK; dORIGMARK; dTARGET;
4326     register SV *cat = TARG;
4327     register I32 items;
4328     STRLEN fromlen;
4329     register char *pat = SvPVx(*++MARK, fromlen);
4330     register char *patend = pat + fromlen;
4331     register I32 len;
4332     I32 datumtype;
4333     SV *fromstr;
4334     /*SUPPRESS 442*/
4335     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4336     static char *space10 = "          ";
4337
4338     /* These must not be in registers: */
4339     char achar;
4340     I16 ashort;
4341     int aint;
4342     unsigned int auint;
4343     I32 along;
4344     U32 aulong;
4345 #ifdef HAS_QUAD
4346     Quad_t aquad;
4347     Uquad_t auquad;
4348 #endif
4349     char *aptr;
4350     float afloat;
4351     double adouble;
4352     int commas = 0;
4353 #ifdef PERL_NATINT_PACK
4354     int natint;         /* native integer */
4355 #endif
4356
4357     items = SP - MARK;
4358     MARK++;
4359     sv_setpvn(cat, "", 0);
4360     while (pat < patend) {
4361 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4362         datumtype = *pat++ & 0xFF;
4363 #ifdef PERL_NATINT_PACK
4364         natint = 0;
4365 #endif
4366         if (isSPACE(datumtype))
4367             continue;
4368         if (*pat == '!') {
4369             char *natstr = "sSiIlL";
4370
4371             if (strchr(natstr, datumtype)) {
4372 #ifdef PERL_NATINT_PACK
4373                 natint = 1;
4374 #endif
4375                 pat++;
4376             }
4377             else
4378                 croak("'!' allowed only after types %s", natstr);
4379         }
4380         if (*pat == '*') {
4381             len = strchr("@Xxu", datumtype) ? 0 : items;
4382             pat++;
4383         }
4384         else if (isDIGIT(*pat)) {
4385             len = *pat++ - '0';
4386             while (isDIGIT(*pat))
4387                 len = (len * 10) + (*pat++ - '0');
4388         }
4389         else
4390             len = 1;
4391         switch(datumtype) {
4392         default:
4393             croak("Invalid type in pack: '%c'", (int)datumtype);
4394         case ',': /* grandfather in commas but with a warning */
4395             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4396                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4397             break;
4398         case '%':
4399             DIE("%% may only be used in unpack");
4400         case '@':
4401             len -= SvCUR(cat);
4402             if (len > 0)
4403                 goto grow;
4404             len = -len;
4405             if (len > 0)
4406                 goto shrink;
4407             break;
4408         case 'X':
4409           shrink:
4410             if (SvCUR(cat) < len)
4411                 DIE("X outside of string");
4412             SvCUR(cat) -= len;
4413             *SvEND(cat) = '\0';
4414             break;
4415         case 'x':
4416           grow:
4417             while (len >= 10) {
4418                 sv_catpvn(cat, null10, 10);
4419                 len -= 10;
4420             }
4421             sv_catpvn(cat, null10, len);
4422             break;
4423         case 'A':
4424         case 'Z':
4425         case 'a':
4426             fromstr = NEXTFROM;
4427             aptr = SvPV(fromstr, fromlen);
4428             if (pat[-1] == '*')
4429                 len = fromlen;
4430             if (fromlen > len)
4431                 sv_catpvn(cat, aptr, len);
4432             else {
4433                 sv_catpvn(cat, aptr, fromlen);
4434                 len -= fromlen;
4435                 if (datumtype == 'A') {
4436                     while (len >= 10) {
4437                         sv_catpvn(cat, space10, 10);
4438                         len -= 10;
4439                     }
4440                     sv_catpvn(cat, space10, len);
4441                 }
4442                 else {
4443                     while (len >= 10) {
4444                         sv_catpvn(cat, null10, 10);
4445                         len -= 10;
4446                     }
4447                     sv_catpvn(cat, null10, len);
4448                 }
4449             }
4450             break;
4451         case 'B':
4452         case 'b':
4453             {
4454                 char *savepat = pat;
4455                 I32 saveitems;
4456
4457                 fromstr = NEXTFROM;
4458                 saveitems = items;
4459                 aptr = SvPV(fromstr, fromlen);
4460                 if (pat[-1] == '*')
4461                     len = fromlen;
4462                 pat = aptr;
4463                 aint = SvCUR(cat);
4464                 SvCUR(cat) += (len+7)/8;
4465                 SvGROW(cat, SvCUR(cat) + 1);
4466                 aptr = SvPVX(cat) + aint;
4467                 if (len > fromlen)
4468                     len = fromlen;
4469                 aint = len;
4470                 items = 0;
4471                 if (datumtype == 'B') {
4472                     for (len = 0; len++ < aint;) {
4473                         items |= *pat++ & 1;
4474                         if (len & 7)
4475                             items <<= 1;
4476                         else {
4477                             *aptr++ = items & 0xff;
4478                             items = 0;
4479                         }
4480                     }
4481                 }
4482                 else {
4483                     for (len = 0; len++ < aint;) {
4484                         if (*pat++ & 1)
4485                             items |= 128;
4486                         if (len & 7)
4487                             items >>= 1;
4488                         else {
4489                             *aptr++ = items & 0xff;
4490                             items = 0;
4491                         }
4492                     }
4493                 }
4494                 if (aint & 7) {
4495                     if (datumtype == 'B')
4496                         items <<= 7 - (aint & 7);
4497                     else
4498                         items >>= 7 - (aint & 7);
4499                     *aptr++ = items & 0xff;
4500                 }
4501                 pat = SvPVX(cat) + SvCUR(cat);
4502                 while (aptr <= pat)
4503                     *aptr++ = '\0';
4504
4505                 pat = savepat;
4506                 items = saveitems;
4507             }
4508             break;
4509         case 'H':
4510         case 'h':
4511             {
4512                 char *savepat = pat;
4513                 I32 saveitems;
4514
4515                 fromstr = NEXTFROM;
4516                 saveitems = items;
4517                 aptr = SvPV(fromstr, fromlen);
4518                 if (pat[-1] == '*')
4519                     len = fromlen;
4520                 pat = aptr;
4521                 aint = SvCUR(cat);
4522                 SvCUR(cat) += (len+1)/2;
4523                 SvGROW(cat, SvCUR(cat) + 1);
4524                 aptr = SvPVX(cat) + aint;
4525                 if (len > fromlen)
4526                     len = fromlen;
4527                 aint = len;
4528                 items = 0;
4529                 if (datumtype == 'H') {
4530                     for (len = 0; len++ < aint;) {
4531                         if (isALPHA(*pat))
4532                             items |= ((*pat++ & 15) + 9) & 15;
4533                         else
4534                             items |= *pat++ & 15;
4535                         if (len & 1)
4536                             items <<= 4;
4537                         else {
4538                             *aptr++ = items & 0xff;
4539                             items = 0;
4540                         }
4541                     }
4542                 }
4543                 else {
4544                     for (len = 0; len++ < aint;) {
4545                         if (isALPHA(*pat))
4546                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4547                         else
4548                             items |= (*pat++ & 15) << 4;
4549                         if (len & 1)
4550                             items >>= 4;
4551                         else {
4552                             *aptr++ = items & 0xff;
4553                             items = 0;
4554                         }
4555                     }
4556                 }
4557                 if (aint & 1)
4558                     *aptr++ = items & 0xff;
4559                 pat = SvPVX(cat) + SvCUR(cat);
4560                 while (aptr <= pat)
4561                     *aptr++ = '\0';
4562
4563                 pat = savepat;
4564                 items = saveitems;
4565             }
4566             break;
4567         case 'C':
4568         case 'c':
4569             while (len-- > 0) {
4570                 fromstr = NEXTFROM;
4571                 aint = SvIV(fromstr);
4572                 achar = aint;
4573                 sv_catpvn(cat, &achar, sizeof(char));
4574             }
4575             break;
4576         case 'U':
4577             while (len-- > 0) {
4578                 fromstr = NEXTFROM;
4579                 auint = SvUV(fromstr);
4580                 SvGROW(cat, SvCUR(cat) + 10);
4581                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4582                                - SvPVX(cat));
4583             }
4584             *SvEND(cat) = '\0';
4585             break;
4586         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4587         case 'f':
4588         case 'F':
4589             while (len-- > 0) {
4590                 fromstr = NEXTFROM;
4591                 afloat = (float)SvNV(fromstr);
4592                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4593             }
4594             break;
4595         case 'd':
4596         case 'D':
4597             while (len-- > 0) {
4598                 fromstr = NEXTFROM;
4599                 adouble = (double)SvNV(fromstr);
4600                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4601             }
4602             break;
4603         case 'n':
4604             while (len-- > 0) {
4605                 fromstr = NEXTFROM;
4606                 ashort = (I16)SvIV(fromstr);
4607 #ifdef HAS_HTONS
4608                 ashort = PerlSock_htons(ashort);
4609 #endif
4610                 CAT16(cat, &ashort);
4611             }
4612             break;
4613         case 'v':
4614             while (len-- > 0) {
4615                 fromstr = NEXTFROM;
4616                 ashort = (I16)SvIV(fromstr);
4617 #ifdef HAS_HTOVS
4618                 ashort = htovs(ashort);
4619 #endif
4620                 CAT16(cat, &ashort);
4621             }
4622             break;
4623         case 'S':
4624 #if SHORTSIZE != SIZE16
4625             if (natint) {
4626                 unsigned short aushort;
4627
4628                 while (len-- > 0) {
4629                     fromstr = NEXTFROM;
4630                     aushort = SvUV(fromstr);
4631                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4632                 }
4633             }
4634             else
4635 #endif
4636             {
4637                 U16 aushort;
4638
4639                 while (len-- > 0) {
4640                     fromstr = NEXTFROM;
4641                     aushort = (U16)SvUV(fromstr);
4642                     CAT16(cat, &aushort);
4643                 }
4644
4645             }
4646             break;
4647         case 's':
4648 #if SHORTSIZE != SIZE16
4649             if (natint) {
4650                 while (len-- > 0) {
4651                     fromstr = NEXTFROM;
4652                     ashort = SvIV(fromstr);
4653                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4654                 }
4655             }
4656             else
4657 #endif
4658             {
4659                 while (len-- > 0) {
4660                     fromstr = NEXTFROM;
4661                     ashort = (I16)SvIV(fromstr);
4662                     CAT16(cat, &ashort);
4663                 }
4664             }
4665             break;
4666         case 'I':
4667             while (len-- > 0) {
4668                 fromstr = NEXTFROM;
4669                 auint = SvUV(fromstr);
4670                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4671             }
4672             break;
4673         case 'w':
4674             while (len-- > 0) {
4675                 fromstr = NEXTFROM;
4676                 adouble = floor(SvNV(fromstr));
4677
4678                 if (adouble < 0)
4679                     croak("Cannot compress negative numbers");
4680
4681                 if (
4682 #ifdef BW_BITS
4683                     adouble <= BW_MASK
4684 #else
4685 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4686                     adouble <= UV_MAX_cxux
4687 #else
4688                     adouble <= UV_MAX
4689 #endif
4690 #endif
4691                     )
4692                 {
4693                     char   buf[1 + sizeof(UV)];
4694                     char  *in = buf + sizeof(buf);
4695                     UV     auv = U_V(adouble);
4696
4697                     do {
4698                         *--in = (auv & 0x7f) | 0x80;
4699                         auv >>= 7;
4700                     } while (auv);
4701                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4702                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4703                 }
4704                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4705                     char           *from, *result, *in;
4706                     SV             *norm;
4707                     STRLEN          len;
4708                     bool            done;
4709
4710                     /* Copy string and check for compliance */
4711                     from = SvPV(fromstr, len);
4712                     if ((norm = is_an_int(from, len)) == NULL)
4713                         croak("can compress only unsigned integer");
4714
4715                     New('w', result, len, char);
4716                     in = result + len;
4717                     done = FALSE;
4718                     while (!done)
4719                         *--in = div128(norm, &done) | 0x80;
4720                     result[len - 1] &= 0x7F; /* clear continue bit */
4721                     sv_catpvn(cat, in, (result + len) - in);
4722                     Safefree(result);
4723                     SvREFCNT_dec(norm); /* free norm */
4724                 }
4725                 else if (SvNOKp(fromstr)) {
4726                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4727                     char  *in = buf + sizeof(buf);
4728
4729                     do {
4730                         double next = floor(adouble / 128);
4731                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4732                         if (--in < buf)  /* this cannot happen ;-) */
4733                             croak ("Cannot compress integer");
4734                         adouble = next;
4735                     } while (adouble > 0);
4736                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4737                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4738                 }
4739                 else
4740                     croak("Cannot compress non integer");
4741             }
4742             break;
4743         case 'i':
4744             while (len-- > 0) {
4745                 fromstr = NEXTFROM;
4746                 aint = SvIV(fromstr);
4747                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4748             }
4749             break;
4750         case 'N':
4751             while (len-- > 0) {
4752                 fromstr = NEXTFROM;
4753                 aulong = SvUV(fromstr);
4754 #ifdef HAS_HTONL
4755                 aulong = PerlSock_htonl(aulong);
4756 #endif
4757                 CAT32(cat, &aulong);
4758             }
4759             break;
4760         case 'V':
4761             while (len-- > 0) {
4762                 fromstr = NEXTFROM;
4763                 aulong = SvUV(fromstr);
4764 #ifdef HAS_HTOVL
4765                 aulong = htovl(aulong);
4766 #endif
4767                 CAT32(cat, &aulong);
4768             }
4769             break;
4770         case 'L':
4771 #if LONGSIZE != SIZE32
4772             if (natint) {
4773                 while (len-- > 0) {
4774                     fromstr = NEXTFROM;
4775                     aulong = SvUV(fromstr);
4776                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4777                 }
4778             }
4779             else
4780 #endif
4781             {
4782                 while (len-- > 0) {
4783                     fromstr = NEXTFROM;
4784                     aulong = SvUV(fromstr);
4785                     CAT32(cat, &aulong);
4786                 }
4787             }
4788             break;
4789         case 'l':
4790 #if LONGSIZE != SIZE32
4791             if (natint) {
4792                 while (len-- > 0) {
4793                     fromstr = NEXTFROM;
4794                     along = SvIV(fromstr);
4795                     sv_catpvn(cat, (char *)&along, sizeof(long));
4796                 }
4797             }
4798             else
4799 #endif
4800             {
4801                 while (len-- > 0) {
4802                     fromstr = NEXTFROM;
4803                     along = SvIV(fromstr);
4804                     CAT32(cat, &along);
4805                 }
4806             }
4807             break;
4808 #ifdef HAS_QUAD
4809         case 'Q':
4810             while (len-- > 0) {
4811                 fromstr = NEXTFROM;
4812                 auquad = (Uquad_t)SvIV(fromstr);
4813                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4814             }
4815             break;
4816         case 'q':
4817             while (len-- > 0) {
4818                 fromstr = NEXTFROM;
4819                 aquad = (Quad_t)SvIV(fromstr);
4820                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4821             }
4822             break;
4823 #endif /* HAS_QUAD */
4824         case 'P':
4825             len = 1;            /* assume SV is correct length */
4826             /* FALL THROUGH */
4827         case 'p':
4828             while (len-- > 0) {
4829                 fromstr = NEXTFROM;
4830                 if (fromstr == &PL_sv_undef)
4831                     aptr = NULL;
4832                 else {
4833                     STRLEN n_a;
4834                     /* XXX better yet, could spirit away the string to
4835                      * a safe spot and hang on to it until the result
4836                      * of pack() (and all copies of the result) are
4837                      * gone.
4838                      */
4839                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4840                         warner(WARN_UNSAFE,
4841                                 "Attempt to pack pointer to temporary value");
4842                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4843                         aptr = SvPV(fromstr,n_a);
4844                     else
4845                         aptr = SvPV_force(fromstr,n_a);
4846                 }
4847                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4848             }
4849             break;
4850         case 'u':
4851             fromstr = NEXTFROM;
4852             aptr = SvPV(fromstr, fromlen);
4853             SvGROW(cat, fromlen * 4 / 3);
4854             if (len <= 1)
4855                 len = 45;
4856             else
4857                 len = len / 3 * 3;
4858             while (fromlen > 0) {
4859                 I32 todo;
4860
4861                 if (fromlen > len)
4862                     todo = len;
4863                 else
4864                     todo = fromlen;
4865                 doencodes(cat, aptr, todo);
4866                 fromlen -= todo;
4867                 aptr += todo;
4868             }
4869             break;
4870         }
4871     }
4872     SvSETMAGIC(cat);
4873     SP = ORIGMARK;
4874     PUSHs(cat);
4875     RETURN;
4876 }
4877 #undef NEXTFROM
4878
4879
4880 PP(pp_split)
4881 {
4882     djSP; dTARG;
4883     AV *ary;
4884     register I32 limit = POPi;                  /* note, negative is forever */
4885     SV *sv = POPs;
4886     STRLEN len;
4887     register char *s = SvPV(sv, len);
4888     char *strend = s + len;
4889     register PMOP *pm;
4890     register REGEXP *rx;
4891     register SV *dstr;
4892     register char *m;
4893     I32 iters = 0;
4894     I32 maxiters = (strend - s) + 10;
4895     I32 i;
4896     char *orig;
4897     I32 origlimit = limit;
4898     I32 realarray = 0;
4899     I32 base;
4900     AV *oldstack = PL_curstack;
4901     I32 gimme = GIMME_V;
4902     I32 oldsave = PL_savestack_ix;
4903     I32 make_mortal = 1;
4904     MAGIC *mg = (MAGIC *) NULL;
4905
4906 #ifdef DEBUGGING
4907     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4908 #else
4909     pm = (PMOP*)POPs;
4910 #endif
4911     if (!pm || !s)
4912         DIE("panic: do_split");
4913     rx = pm->op_pmregexp;
4914
4915     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4916              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4917
4918     if (pm->op_pmreplroot)
4919         ary = GvAVn((GV*)pm->op_pmreplroot);
4920     else if (gimme != G_ARRAY)
4921 #ifdef USE_THREADS
4922         ary = (AV*)PL_curpad[0];
4923 #else
4924         ary = GvAVn(PL_defgv);
4925 #endif /* USE_THREADS */
4926     else
4927         ary = Nullav;
4928     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4929         realarray = 1;
4930         PUTBACK;
4931         av_extend(ary,0);
4932         av_clear(ary);
4933         SPAGAIN;
4934         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4935             PUSHMARK(SP);
4936             XPUSHs(SvTIED_obj((SV*)ary, mg));
4937         }
4938         else {
4939             if (!AvREAL(ary)) {
4940                 AvREAL_on(ary);
4941                 for (i = AvFILLp(ary); i >= 0; i--)
4942                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4943             }
4944             /* temporarily switch stacks */
4945             SWITCHSTACK(PL_curstack, ary);
4946             make_mortal = 0;
4947         }
4948     }
4949     base = SP - PL_stack_base;
4950     orig = s;
4951     if (pm->op_pmflags & PMf_SKIPWHITE) {
4952         if (pm->op_pmflags & PMf_LOCALE) {
4953             while (isSPACE_LC(*s))
4954                 s++;
4955         }
4956         else {
4957             while (isSPACE(*s))
4958                 s++;
4959         }
4960     }
4961     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4962         SAVEINT(PL_multiline);
4963         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4964     }
4965
4966     if (!limit)
4967         limit = maxiters + 2;
4968     if (pm->op_pmflags & PMf_WHITE) {
4969         while (--limit) {
4970             m = s;
4971             while (m < strend &&
4972                    !((pm->op_pmflags & PMf_LOCALE)
4973                      ? isSPACE_LC(*m) : isSPACE(*m)))
4974                 ++m;
4975             if (m >= strend)
4976                 break;
4977
4978             dstr = NEWSV(30, m-s);
4979             sv_setpvn(dstr, s, m-s);
4980             if (make_mortal)
4981                 sv_2mortal(dstr);
4982             XPUSHs(dstr);
4983
4984             s = m + 1;
4985             while (s < strend &&
4986                    ((pm->op_pmflags & PMf_LOCALE)
4987                     ? isSPACE_LC(*s) : isSPACE(*s)))
4988                 ++s;
4989         }
4990     }
4991     else if (strEQ("^", rx->precomp)) {
4992         while (--limit) {
4993             /*SUPPRESS 530*/
4994             for (m = s; m < strend && *m != '\n'; m++) ;
4995             m++;
4996             if (m >= strend)
4997                 break;
4998             dstr = NEWSV(30, m-s);
4999             sv_setpvn(dstr, s, m-s);
5000             if (make_mortal)
5001                 sv_2mortal(dstr);
5002             XPUSHs(dstr);
5003             s = m;
5004         }
5005     }
5006     else if (rx->check_substr && !rx->nparens
5007              && (rx->reganch & ROPT_CHECK_ALL)
5008              && !(rx->reganch & ROPT_ANCH)) {
5009         int tail = SvTAIL(rx->check_substr) != 0;
5010
5011         i = SvCUR(rx->check_substr);
5012         if (i == 1 && !tail) {
5013             i = *SvPVX(rx->check_substr);
5014             while (--limit) {
5015                 /*SUPPRESS 530*/
5016                 for (m = s; m < strend && *m != i; m++) ;
5017                 if (m >= strend)
5018                     break;
5019                 dstr = NEWSV(30, m-s);
5020                 sv_setpvn(dstr, s, m-s);
5021                 if (make_mortal)
5022                     sv_2mortal(dstr);
5023                 XPUSHs(dstr);
5024                 s = m + 1;
5025             }
5026         }
5027         else {
5028 #ifndef lint
5029             while (s < strend && --limit &&
5030               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5031                     rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
5032 #endif
5033             {
5034                 dstr = NEWSV(31, m-s);
5035                 sv_setpvn(dstr, s, m-s);
5036                 if (make_mortal)
5037                     sv_2mortal(dstr);
5038                 XPUSHs(dstr);
5039                 s = m + i - tail;       /* Fake \n at the end */
5040             }
5041         }
5042     }
5043     else {
5044         maxiters += (strend - s) * rx->nparens;
5045         while (s < strend && --limit &&
5046                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5047         {
5048             TAINT_IF(RX_MATCH_TAINTED(rx));
5049             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5050                 m = s;
5051                 s = orig;
5052                 orig = rx->subbeg;
5053                 s = orig + (m - s);
5054                 strend = s + (strend - m);
5055             }
5056             m = rx->startp[0] + orig;
5057             dstr = NEWSV(32, m-s);
5058             sv_setpvn(dstr, s, m-s);
5059             if (make_mortal)
5060                 sv_2mortal(dstr);
5061             XPUSHs(dstr);
5062             if (rx->nparens) {
5063                 for (i = 1; i <= rx->nparens; i++) {
5064                     s = rx->startp[i] + orig;
5065                     m = rx->endp[i] + orig;
5066                     if (m && s) {
5067                         dstr = NEWSV(33, m-s);
5068                         sv_setpvn(dstr, s, m-s);
5069                     }
5070                     else
5071                         dstr = NEWSV(33, 0);
5072                     if (make_mortal)
5073                         sv_2mortal(dstr);
5074                     XPUSHs(dstr);
5075                 }
5076             }
5077             s = rx->endp[0] + orig;
5078         }
5079     }
5080
5081     LEAVE_SCOPE(oldsave);
5082     iters = (SP - PL_stack_base) - base;
5083     if (iters > maxiters)
5084         DIE("Split loop");
5085
5086     /* keep field after final delim? */
5087     if (s < strend || (iters && origlimit)) {
5088         dstr = NEWSV(34, strend-s);
5089         sv_setpvn(dstr, s, strend-s);
5090         if (make_mortal)
5091             sv_2mortal(dstr);
5092         XPUSHs(dstr);
5093         iters++;
5094     }
5095     else if (!origlimit) {
5096         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5097             iters--, SP--;
5098     }
5099
5100     if (realarray) {
5101         if (!mg) {
5102             SWITCHSTACK(ary, oldstack);
5103             if (SvSMAGICAL(ary)) {
5104                 PUTBACK;
5105                 mg_set((SV*)ary);
5106                 SPAGAIN;
5107             }
5108             if (gimme == G_ARRAY) {
5109                 EXTEND(SP, iters);
5110                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5111                 SP += iters;
5112                 RETURN;
5113             }
5114         }
5115         else {
5116             PUTBACK;
5117             ENTER;
5118             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5119             LEAVE;
5120             SPAGAIN;
5121             if (gimme == G_ARRAY) {
5122                 /* EXTEND should not be needed - we just popped them */
5123                 EXTEND(SP, iters);
5124                 for (i=0; i < iters; i++) {
5125                     SV **svp = av_fetch(ary, i, FALSE);
5126                     PUSHs((svp) ? *svp : &PL_sv_undef);
5127                 }
5128                 RETURN;
5129             }
5130         }
5131     }
5132     else {
5133         if (gimme == G_ARRAY)
5134             RETURN;
5135     }
5136     if (iters || !pm->op_pmreplroot) {
5137         GETTARGET;
5138         PUSHi(iters);
5139         RETURN;
5140     }
5141     RETPUSHUNDEF;
5142 }
5143
5144 #ifdef USE_THREADS
5145 void
5146 unlock_condpair(void *svv)
5147 {
5148     dTHR;
5149     MAGIC *mg = mg_find((SV*)svv, 'm');
5150
5151     if (!mg)
5152         croak("panic: unlock_condpair unlocking non-mutex");
5153     MUTEX_LOCK(MgMUTEXP(mg));
5154     if (MgOWNER(mg) != thr)
5155         croak("panic: unlock_condpair unlocking mutex that we don't own");
5156     MgOWNER(mg) = 0;
5157     COND_SIGNAL(MgOWNERCONDP(mg));
5158     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5159                           (unsigned long)thr, (unsigned long)svv);)
5160     MUTEX_UNLOCK(MgMUTEXP(mg));
5161 }
5162 #endif /* USE_THREADS */
5163
5164 PP(pp_lock)
5165 {
5166     djSP;
5167     dTOPss;
5168     SV *retsv = sv;
5169 #ifdef USE_THREADS
5170     MAGIC *mg;
5171
5172     if (SvROK(sv))
5173         sv = SvRV(sv);
5174
5175     mg = condpair_magic(sv);
5176     MUTEX_LOCK(MgMUTEXP(mg));
5177     if (MgOWNER(mg) == thr)
5178         MUTEX_UNLOCK(MgMUTEXP(mg));
5179     else {
5180         while (MgOWNER(mg))
5181             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5182         MgOWNER(mg) = thr;
5183         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5184                               (unsigned long)thr, (unsigned long)sv);)
5185         MUTEX_UNLOCK(MgMUTEXP(mg));
5186         save_destructor(unlock_condpair, sv);
5187     }
5188 #endif /* USE_THREADS */
5189     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5190         || SvTYPE(retsv) == SVt_PVCV) {
5191         retsv = refto(retsv);
5192     }
5193     SETs(retsv);
5194     RETURN;
5195 }
5196
5197 PP(pp_threadsv)
5198 {
5199     djSP;
5200 #ifdef USE_THREADS
5201     EXTEND(SP, 1);
5202     if (PL_op->op_private & OPpLVAL_INTRO)
5203         PUSHs(*save_threadsv(PL_op->op_targ));
5204     else
5205         PUSHs(THREADSV(PL_op->op_targ));
5206     RETURN;
5207 #else
5208     DIE("tried to access per-thread data in non-threaded perl");
5209 #endif /* USE_THREADS */
5210 }