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