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