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