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