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