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