pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "It's a big house this, and very peculiar.  Always a bit more to discover,
  12  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
  13  */
  14
  15 #include "EXTERN.h"
  16 #define PERL_IN_PP_C
  17 #include "perl.h"
  18
  19 /*
  20  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  21  * seems to show up when compiling pp.c - it generates the wrong double
  22  * precision constant value for (double)UV_MAX when used inline in the body
  23  * of the code below, so this makes a static variable up front (which the
  24  * compiler seems to get correct) and uses it in place of UV_MAX below.
  25  */
  26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  27 static double UV_MAX_cxux = ((double)UV_MAX);
  28 #endif
  29
  30 /*
  31  * Types used in bitwise operations.
  32  *
  33  * Normally we'd just use IV and UV.  However, some hardware and
  34  * software combinations (e.g. Alpha and current OSF/1) don't have a
  35  * floating-point type to use for NV that has adequate bits to fully
  36  * hold an IV/UV.  (In other words, sizeof(long) == sizeof(double).)
  37  *
  38  * It just so happens that "int" is the right size almost everywhere.
  39  */
  40 typedef int IBW;
  41 typedef unsigned UBW;
  42
  43 /*
  44  * Mask used after bitwise operations.
  45  *
  46  * There is at least one realm (Cray word machines) that doesn't
  47  * have an integral type (except char) small enough to be represented
  48  * in a double without loss; that is, it has no 32-bit type.
  49  */
  50 #if LONGSIZE > 4  && defined(_CRAY) && !defined(_CRAYMPP)
  51 #  define BW_BITS  32
  52 #  define BW_MASK  ((1 << BW_BITS) - 1)
  53 #  define BW_SIGN  (1 << (BW_BITS - 1))
  54 #  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
  55 #  define BWu(u)  ((u) & BW_MASK)
  56 #else
  57 #  define BWi(i)  (i)
  58 #  define BWu(u)  (u)
  59 #endif
  60
  61 /*
  62  * Offset for integer pack/unpack.
  63  *
  64  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  65  * which for now are all Crays, pack and unpack have to play games.
  66  */
  67
  68 /*
  69  * These values are required for portability of pack() output.
  70  * If they're not right on your machine, then pack() and unpack()
  71  * wouldn't work right anyway; you'll need to apply the Cray hack.
  72  * (I'd like to check them with #if, but you can't use sizeof() in
  73  * the preprocessor.)  --???
  74  */
  75 /*
  76     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  77     defines are now in config.h.  --Andy Dougherty  April 1998
  78  */
  79 #define SIZE16 2
  80 #define SIZE32 4
  81
  82 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  83    --jhi Feb 1999 */
  84
  85 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  86 #   define PERL_NATINT_PACK
  87 #endif
  88
  89 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
  90 #  if BYTEORDER == 0x12345678
  91 #    define OFF16(p)    (char*)(p)
  92 #    define OFF32(p)    (char*)(p)
  93 #  else
  94 #    if BYTEORDER == 0x87654321
  95 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  96 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  97 #    else
  98        }}}} bad cray byte order
  99 #    endif
 100 #  endif
 101 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
 102 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
 103 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
 104 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
 105 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
 106 #else
 107 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
 108 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
 109 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
 110 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
 111 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
 112 #endif
 113
 114 /* variations on pp_null */
 115
 116 #ifdef I_UNISTD
 117 #include <unistd.h>
 118 #endif
 119
 120 /* XXX I can't imagine anyone who doesn't have this actually _needs_
 121    it, since pid_t is an integral type.
 122    --AD  2/20/1998
 123 */
 124 #ifdef NEED_GETPID_PROTO
 125 extern Pid_t getpid (void);
 126 #endif
 127
 128 PP(pp_stub)
 129 {
 130     djSP;
 131     if (GIMME_V == G_SCALAR)
 132         XPUSHs(&PL_sv_undef);
 133     RETURN;
 134 }
 135
 136 PP(pp_scalar)
 137 {
 138     return NORMAL;
 139 }
 140
 141 /* Pushy stuff. */
 142
 143 PP(pp_padav)
 144 {
 145     djSP; dTARGET;
 146     if (PL_op->op_private & OPpLVAL_INTRO)
 147         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 148     EXTEND(SP, 1);
 149     if (PL_op->op_flags & OPf_REF) {
 150         PUSHs(TARG);
 151         RETURN;
 152     }
 153     if (GIMME == G_ARRAY) {
 154         I32 maxarg = AvFILL((AV*)TARG) + 1;
 155         EXTEND(SP, maxarg);
 156         if (SvMAGICAL(TARG)) {
 157             U32 i;
 158             for (i=0; i < maxarg; i++) {
 159                 SV **svp = av_fetch((AV*)TARG, i, FALSE);
 160                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 161             }
 162         }
 163         else {
 164             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
 165         }
 166         SP += maxarg;
 167     }
 168     else {
 169         SV* sv = sv_newmortal();
 170         I32 maxarg = AvFILL((AV*)TARG) + 1;
 171         sv_setiv(sv, maxarg);
 172         PUSHs(sv);
 173     }
 174     RETURN;
 175 }
 176
 177 PP(pp_padhv)
 178 {
 179     djSP; dTARGET;
 180     I32 gimme;
 181
 182     XPUSHs(TARG);
 183     if (PL_op->op_private & OPpLVAL_INTRO)
 184         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 185     if (PL_op->op_flags & OPf_REF)
 186         RETURN;
 187     gimme = GIMME_V;
 188     if (gimme == G_ARRAY) {
 189         RETURNOP(do_kv());
 190     }
 191     else if (gimme == G_SCALAR) {
 192         SV* sv = sv_newmortal();
 193         if (HvFILL((HV*)TARG))
 194             Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
 195                       (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
 196         else
 197             sv_setiv(sv, 0);
 198         SETs(sv);
 199     }
 200     RETURN;
 201 }
 202
 203 PP(pp_padany)
 204 {
 205     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
 206 }
 207
 208 /* Translations. */
 209
 210 PP(pp_rv2gv)
 211 {
 212     djSP; dTOPss;
 213
 214     if (SvROK(sv)) {
 215       wasref:
 216         tryAMAGICunDEREF(to_gv);
 217
 218         sv = SvRV(sv);
 219         if (SvTYPE(sv) == SVt_PVIO) {
 220             GV *gv = (GV*) sv_newmortal();
 221             gv_init(gv, 0, "", 0, 0);
 222             GvIOp(gv) = (IO *)sv;
 223             (void)SvREFCNT_inc(sv);
 224             sv = (SV*) gv;
 225         }
 226         else if (SvTYPE(sv) != SVt_PVGV)
 227             DIE(aTHX_ "Not a GLOB reference");
 228     }
 229     else {
 230         if (SvTYPE(sv) != SVt_PVGV) {
 231             char *sym;
 232             STRLEN n_a;
 233
 234             if (SvGMAGICAL(sv)) {
 235                 mg_get(sv);
 236                 if (SvROK(sv))
 237                     goto wasref;
 238             }
 239             if (!SvOK(sv)) {
 240                 /* If this is a 'my' scalar and flag is set then vivify
 241                  * NI-S 1999/05/07
 242                  */
 243                 if (PL_op->op_private & OPpDEREF) {
 244                     GV *gv = (GV *) newSV(0);
 245                     STRLEN len = 0;
 246                     char *name = "";
 247                     if (cUNOP->op_first->op_type == OP_PADSV) {
 248                         SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
 249                         name = SvPV(padname,len);
 250                     }
 251                     gv_init(gv, PL_curcop->cop_stash, name, len, 0);
 252                     sv_upgrade(sv, SVt_RV);
 253                     SvRV(sv) = (SV *) gv;
 254                     SvROK_on(sv);
 255                     SvSETMAGIC(sv);
 256                     goto wasref;
 257                 }
 258                 if (PL_op->op_flags & OPf_REF ||
 259                     PL_op->op_private & HINT_STRICT_REFS)
 260                     DIE(aTHX_ PL_no_usym, "a symbol");
 261                 if (ckWARN(WARN_UNINITIALIZED))
 262                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 263                 RETSETUNDEF;
 264             }
 265             sym = SvPV(sv, n_a);
 266             if ((PL_op->op_flags & OPf_SPECIAL) &&
 267                 !(PL_op->op_flags & OPf_MOD))
 268             {
 269                 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
 270                 if (!sv)
 271                     RETSETUNDEF;
 272             }
 273             else {
 274                 if (PL_op->op_private & HINT_STRICT_REFS)
 275                     DIE(aTHX_ PL_no_symref, sym, "a symbol");
 276                 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
 277             }
 278         }
 279     }
 280     if (PL_op->op_private & OPpLVAL_INTRO)
 281         save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
 282     SETs(sv);
 283     RETURN;
 284 }
 285
 286 PP(pp_rv2sv)
 287 {
 288     djSP; dTOPss;
 289
 290     if (SvROK(sv)) {
 291       wasref:
 292         tryAMAGICunDEREF(to_sv);
 293
 294         sv = SvRV(sv);
 295         switch (SvTYPE(sv)) {
 296         case SVt_PVAV:
 297         case SVt_PVHV:
 298         case SVt_PVCV:
 299             DIE(aTHX_ "Not a SCALAR reference");
 300         }
 301     }
 302     else {
 303         GV *gv = (GV*)sv;
 304         char *sym;
 305         STRLEN n_a;
 306
 307         if (SvTYPE(gv) != SVt_PVGV) {
 308             if (SvGMAGICAL(sv)) {
 309                 mg_get(sv);
 310                 if (SvROK(sv))
 311                     goto wasref;
 312             }
 313             if (!SvOK(sv)) {
 314                 if (PL_op->op_flags & OPf_REF ||
 315                     PL_op->op_private & HINT_STRICT_REFS)
 316                     DIE(aTHX_ PL_no_usym, "a SCALAR");
 317                 if (ckWARN(WARN_UNINITIALIZED))
 318                     Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 319                 RETSETUNDEF;
 320             }
 321             sym = SvPV(sv, n_a);
 322             if ((PL_op->op_flags & OPf_SPECIAL) &&
 323                 !(PL_op->op_flags & OPf_MOD))
 324             {
 325                 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
 326                 if (!gv)
 327                     RETSETUNDEF;
 328             }
 329             else {
 330                 if (PL_op->op_private & HINT_STRICT_REFS)
 331                     DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
 332                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
 333             }
 334         }
 335         sv = GvSV(gv);
 336     }
 337     if (PL_op->op_flags & OPf_MOD) {
 338         if (PL_op->op_private & OPpLVAL_INTRO)
 339             sv = save_scalar((GV*)TOPs);
 340         else if (PL_op->op_private & OPpDEREF)
 341             vivify_ref(sv, PL_op->op_private & OPpDEREF);
 342     }
 343     SETs(sv);
 344     RETURN;
 345 }
 346
 347 PP(pp_av2arylen)
 348 {
 349     djSP;
 350     AV *av = (AV*)TOPs;
 351     SV *sv = AvARYLEN(av);
 352     if (!sv) {
 353         AvARYLEN(av) = sv = NEWSV(0,0);
 354         sv_upgrade(sv, SVt_IV);
 355         sv_magic(sv, (SV*)av, '#', Nullch, 0);
 356     }
 357     SETs(sv);
 358     RETURN;
 359 }
 360
 361 PP(pp_pos)
 362 {
 363     djSP; dTARGET; dPOPss;
 364
 365     if (PL_op->op_flags & OPf_MOD) {
 366         if (SvTYPE(TARG) < SVt_PVLV) {
 367             sv_upgrade(TARG, SVt_PVLV);
 368             sv_magic(TARG, Nullsv, '.', Nullch, 0);
 369         }
 370
 371         LvTYPE(TARG) = '.';
 372         if (LvTARG(TARG) != sv) {
 373             if (LvTARG(TARG))
 374                 SvREFCNT_dec(LvTARG(TARG));
 375             LvTARG(TARG) = SvREFCNT_inc(sv);
 376         }
 377         PUSHs(TARG);    /* no SvSETMAGIC */
 378         RETURN;
 379     }
 380     else {
 381         MAGIC* mg;
 382
 383         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 384             mg = mg_find(sv, 'g');
 385             if (mg && mg->mg_len >= 0) {
 386                 I32 i = mg->mg_len;
 387                 if (IN_UTF8)
 388                     sv_pos_b2u(sv, &i);
 389                 PUSHi(i + PL_curcop->cop_arybase);
 390                 RETURN;
 391             }
 392         }
 393         RETPUSHUNDEF;
 394     }
 395 }
 396
 397 PP(pp_rv2cv)
 398 {
 399     djSP;
 400     GV *gv;
 401     HV *stash;
 402
 403     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 404     /* (But not in defined().) */
 405     CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
 406     if (cv) {
 407         if (CvCLONE(cv))
 408             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 409     }
 410     else
 411         cv = (CV*)&PL_sv_undef;
 412     SETs((SV*)cv);
 413     RETURN;
 414 }
 415
 416 PP(pp_prototype)
 417 {
 418     djSP;
 419     CV *cv;
 420     HV *stash;
 421     GV *gv;
 422     SV *ret;
 423
 424     ret = &PL_sv_undef;
 425     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 426         char *s = SvPVX(TOPs);
 427         if (strnEQ(s, "CORE::", 6)) {
 428             int code;
 429
 430             code = keyword(s + 6, SvCUR(TOPs) - 6);
 431             if (code < 0) {     /* Overridable. */
 432 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 433                 int i = 0, n = 0, seen_question = 0;
 434                 I32 oa;
 435                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 436
 437                 while (i < MAXO) {      /* The slow way. */
 438                     if (strEQ(s + 6, PL_op_name[i])
 439                         || strEQ(s + 6, PL_op_desc[i]))
 440                     {
 441                         goto found;
 442                     }
 443                     i++;
 444                 }
 445                 goto nonesuch;          /* Should not happen... */
 446               found:
 447                 oa = PL_opargs[i] >> OASHIFT;
 448                 while (oa) {
 449                     if (oa & OA_OPTIONAL) {
 450                         seen_question = 1;
 451                         str[n++] = ';';
 452                     }
 453                     else if (seen_question)
 454                         goto set;       /* XXXX system, exec */
 455                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 456                         && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
 457                         str[n++] = '\\';
 458                     }
 459                     /* What to do with R ((un)tie, tied, (sys)read, recv)? */
 460                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 461                     oa = oa >> 4;
 462                 }
 463                 str[n++] = '\0';
 464                 ret = sv_2mortal(newSVpvn(str, n - 1));
 465             }
 466             else if (code)              /* Non-Overridable */
 467                 goto set;
 468             else {                      /* None such */
 469               nonesuch:
 470                 Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
 471             }
 472         }
 473     }
 474     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 475     if (cv && SvPOK(cv))
 476         ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
 477   set:
 478     SETs(ret);
 479     RETURN;
 480 }
 481
 482 PP(pp_anoncode)
 483 {
 484     djSP;
 485     CV* cv = (CV*)PL_curpad[PL_op->op_targ];
 486     if (CvCLONE(cv))
 487         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 488     EXTEND(SP,1);
 489     PUSHs((SV*)cv);
 490     RETURN;
 491 }
 492
 493 PP(pp_srefgen)
 494 {
 495     djSP;
 496     *SP = refto(*SP);
 497     RETURN;
 498 }
 499
 500 PP(pp_refgen)
 501 {
 502     djSP; dMARK;
 503     if (GIMME != G_ARRAY) {
 504         if (++MARK <= SP)
 505             *MARK = *SP;
 506         else
 507             *MARK = &PL_sv_undef;
 508         *MARK = refto(*MARK);
 509         SP = MARK;
 510         RETURN;
 511     }
 512     EXTEND_MORTAL(SP - MARK);
 513     while (++MARK <= SP)
 514         *MARK = refto(*MARK);
 515     RETURN;
 516 }
 517
 518 STATIC SV*
 519 S_refto(pTHX_ SV *sv)
 520 {
 521     SV* rv;
 522
 523     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 524         if (LvTARGLEN(sv))
 525             vivify_defelem(sv);
 526         if (!(sv = LvTARG(sv)))
 527             sv = &PL_sv_undef;
 528         else
 529             (void)SvREFCNT_inc(sv);
 530     }
 531     else if (SvPADTMP(sv))
 532         sv = newSVsv(sv);
 533     else {
 534         SvTEMP_off(sv);
 535         (void)SvREFCNT_inc(sv);
 536     }
 537     rv = sv_newmortal();
 538     sv_upgrade(rv, SVt_RV);
 539     SvRV(rv) = sv;
 540     SvROK_on(rv);
 541     return rv;
 542 }
 543
 544 PP(pp_ref)
 545 {
 546     djSP; dTARGET;
 547     SV *sv;
 548     char *pv;
 549
 550     sv = POPs;
 551
 552     if (sv && SvGMAGICAL(sv))
 553         mg_get(sv);
 554
 555     if (!sv || !SvROK(sv))
 556         RETPUSHNO;
 557
 558     sv = SvRV(sv);
 559     pv = sv_reftype(sv,TRUE);
 560     PUSHp(pv, strlen(pv));
 561     RETURN;
 562 }
 563
 564 PP(pp_bless)
 565 {
 566     djSP;
 567     HV *stash;
 568
 569     if (MAXARG == 1)
 570         stash = PL_curcop->cop_stash;
 571     else {
 572         SV *ssv = POPs;
 573         STRLEN len;
 574         char *ptr = SvPV(ssv,len);
 575         if (ckWARN(WARN_UNSAFE) && len == 0)
 576             Perl_warner(aTHX_ WARN_UNSAFE,
 577                    "Explicit blessing to '' (assuming package main)");
 578         stash = gv_stashpvn(ptr, len, TRUE);
 579     }
 580
 581     (void)sv_bless(TOPs, stash);
 582     RETURN;
 583 }
 584
 585 PP(pp_gelem)
 586 {
 587     GV *gv;
 588     SV *sv;
 589     SV *tmpRef;
 590     char *elem;
 591     djSP;
 592     STRLEN n_a;
 593
 594     sv = POPs;
 595     elem = SvPV(sv, n_a);
 596     gv = (GV*)POPs;
 597     tmpRef = Nullsv;
 598     sv = Nullsv;
 599     switch (elem ? *elem : '\0')
 600     {
 601     case 'A':
 602         if (strEQ(elem, "ARRAY"))
 603             tmpRef = (SV*)GvAV(gv);
 604         break;
 605     case 'C':
 606         if (strEQ(elem, "CODE"))
 607             tmpRef = (SV*)GvCVu(gv);
 608         break;
 609     case 'F':
 610         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 611             tmpRef = (SV*)GvIOp(gv);
 612         break;
 613     case 'G':
 614         if (strEQ(elem, "GLOB"))
 615             tmpRef = (SV*)gv;
 616         break;
 617     case 'H':
 618         if (strEQ(elem, "HASH"))
 619             tmpRef = (SV*)GvHV(gv);
 620         break;
 621     case 'I':
 622         if (strEQ(elem, "IO"))
 623             tmpRef = (SV*)GvIOp(gv);
 624         break;
 625     case 'N':
 626         if (strEQ(elem, "NAME"))
 627             sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
 628         break;
 629     case 'P':
 630         if (strEQ(elem, "PACKAGE"))
 631             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 632         break;
 633     case 'S':
 634         if (strEQ(elem, "SCALAR"))
 635             tmpRef = GvSV(gv);
 636         break;
 637     }
 638     if (tmpRef)
 639         sv = newRV(tmpRef);
 640     if (sv)
 641         sv_2mortal(sv);
 642     else
 643         sv = &PL_sv_undef;
 644     XPUSHs(sv);
 645     RETURN;
 646 }
 647
 648 /* Pattern matching */
 649
 650 PP(pp_study)
 651 {
 652     djSP; dPOPss;
 653     register unsigned char *s;
 654     register I32 pos;
 655     register I32 ch;
 656     register I32 *sfirst;
 657     register I32 *snext;
 658     STRLEN len;
 659
 660     if (sv == PL_lastscream) {
 661         if (SvSCREAM(sv))
 662             RETPUSHYES;
 663     }
 664     else {
 665         if (PL_lastscream) {
 666             SvSCREAM_off(PL_lastscream);
 667             SvREFCNT_dec(PL_lastscream);
 668         }
 669         PL_lastscream = SvREFCNT_inc(sv);
 670     }
 671
 672     s = (unsigned char*)(SvPV(sv, len));
 673     pos = len;
 674     if (pos <= 0)
 675         RETPUSHNO;
 676     if (pos > PL_maxscream) {
 677         if (PL_maxscream < 0) {
 678             PL_maxscream = pos + 80;
 679             New(301, PL_screamfirst, 256, I32);
 680             New(302, PL_screamnext, PL_maxscream, I32);
 681         }
 682         else {
 683             PL_maxscream = pos + pos / 4;
 684             Renew(PL_screamnext, PL_maxscream, I32);
 685         }
 686     }
 687
 688     sfirst = PL_screamfirst;
 689     snext = PL_screamnext;
 690
 691     if (!sfirst || !snext)
 692         DIE(aTHX_ "do_study: out of memory");
 693
 694     for (ch = 256; ch; --ch)
 695         *sfirst++ = -1;
 696     sfirst -= 256;
 697
 698     while (--pos >= 0) {
 699         ch = s[pos];
 700         if (sfirst[ch] >= 0)
 701             snext[pos] = sfirst[ch] - pos;
 702         else
 703             snext[pos] = -pos;
 704         sfirst[ch] = pos;
 705     }
 706
 707     SvSCREAM_on(sv);
 708     sv_magic(sv, Nullsv, 'g', Nullch, 0);       /* piggyback on m//g magic */
 709     RETPUSHYES;
 710 }
 711
 712 PP(pp_trans)
 713 {
 714     djSP; dTARG;
 715     SV *sv;
 716
 717     if (PL_op->op_flags & OPf_STACKED)
 718         sv = POPs;
 719     else {
 720         sv = DEFSV;
 721         EXTEND(SP,1);
 722     }
 723     TARG = sv_newmortal();
 724     PUSHi(do_trans(sv));
 725     RETURN;
 726 }
 727
 728 /* Lvalue operators. */
 729
 730 PP(pp_schop)
 731 {
 732     djSP; dTARGET;
 733     do_chop(TARG, TOPs);
 734     SETTARG;
 735     RETURN;
 736 }
 737
 738 PP(pp_chop)
 739 {
 740     djSP; dMARK; dTARGET;
 741     while (SP > MARK)
 742         do_chop(TARG, POPs);
 743     PUSHTARG;
 744     RETURN;
 745 }
 746
 747 PP(pp_schomp)
 748 {
 749     djSP; dTARGET;
 750     SETi(do_chomp(TOPs));
 751     RETURN;
 752 }
 753
 754 PP(pp_chomp)
 755 {
 756     djSP; dMARK; dTARGET;
 757     register I32 count = 0;
 758
 759     while (SP > MARK)
 760         count += do_chomp(POPs);
 761     PUSHi(count);
 762     RETURN;
 763 }
 764
 765 PP(pp_defined)
 766 {
 767     djSP;
 768     register SV* sv;
 769
 770     sv = POPs;
 771     if (!sv || !SvANY(sv))
 772         RETPUSHNO;
 773     switch (SvTYPE(sv)) {
 774     case SVt_PVAV:
 775         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 776             RETPUSHYES;
 777         break;
 778     case SVt_PVHV:
 779         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
 780             RETPUSHYES;
 781         break;
 782     case SVt_PVCV:
 783         if (CvROOT(sv) || CvXSUB(sv))
 784             RETPUSHYES;
 785         break;
 786     default:
 787         if (SvGMAGICAL(sv))
 788             mg_get(sv);
 789         if (SvOK(sv))
 790             RETPUSHYES;
 791     }
 792     RETPUSHNO;
 793 }
 794
 795 PP(pp_undef)
 796 {
 797     djSP;
 798     SV *sv;
 799
 800     if (!PL_op->op_private) {
 801         EXTEND(SP, 1);
 802         RETPUSHUNDEF;
 803     }
 804
 805     sv = POPs;
 806     if (!sv)
 807         RETPUSHUNDEF;
 808
 809     if (SvTHINKFIRST(sv))
 810         sv_force_normal(sv);
 811
 812     switch (SvTYPE(sv)) {
 813     case SVt_NULL:
 814         break;
 815     case SVt_PVAV:
 816         av_undef((AV*)sv);
 817         break;
 818     case SVt_PVHV:
 819         hv_undef((HV*)sv);
 820         break;
 821     case SVt_PVCV:
 822         if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
 823             Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
 824                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 825         /* FALL THROUGH */
 826     case SVt_PVFM:
 827         {
 828             /* let user-undef'd sub keep its identity */
 829             GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
 830             cv_undef((CV*)sv);
 831             CvGV((CV*)sv) = gv;
 832         }
 833         break;
 834     case SVt_PVGV:
 835         if (SvFAKE(sv))
 836             SvSetMagicSV(sv, &PL_sv_undef);
 837         else {
 838             GP *gp;
 839             gp_free((GV*)sv);
 840             Newz(602, gp, 1, GP);
 841             GvGP(sv) = gp_ref(gp);
 842             GvSV(sv) = NEWSV(72,0);
 843             GvLINE(sv) = PL_curcop->cop_line;
 844             GvEGV(sv) = (GV*)sv;
 845             GvMULTI_on(sv);
 846         }
 847         break;
 848     default:
 849         if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
 850             (void)SvOOK_off(sv);
 851             Safefree(SvPVX(sv));
 852             SvPV_set(sv, Nullch);
 853             SvLEN_set(sv, 0);
 854         }
 855         (void)SvOK_off(sv);
 856         SvSETMAGIC(sv);
 857     }
 858
 859     RETPUSHUNDEF;
 860 }
 861
 862 PP(pp_predec)
 863 {
 864     djSP;
 865     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 866         Perl_croak(aTHX_ PL_no_modify);
 867     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 868         SvIVX(TOPs) != IV_MIN)
 869     {
 870         --SvIVX(TOPs);
 871         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 872     }
 873     else
 874         sv_dec(TOPs);
 875     SvSETMAGIC(TOPs);
 876     return NORMAL;
 877 }
 878
 879 PP(pp_postinc)
 880 {
 881     djSP; dTARGET;
 882     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 883         Perl_croak(aTHX_ PL_no_modify);
 884     sv_setsv(TARG, TOPs);
 885     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 886         SvIVX(TOPs) != IV_MAX)
 887     {
 888         ++SvIVX(TOPs);
 889         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 890     }
 891     else
 892         sv_inc(TOPs);
 893     SvSETMAGIC(TOPs);
 894     if (!SvOK(TARG))
 895         sv_setiv(TARG, 0);
 896     SETs(TARG);
 897     return NORMAL;
 898 }
 899
 900 PP(pp_postdec)
 901 {
 902     djSP; dTARGET;
 903     if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 904         Perl_croak(aTHX_ PL_no_modify);
 905     sv_setsv(TARG, TOPs);
 906     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 907         SvIVX(TOPs) != IV_MIN)
 908     {
 909         --SvIVX(TOPs);
 910         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 911     }
 912     else
 913         sv_dec(TOPs);
 914     SvSETMAGIC(TOPs);
 915     SETs(TARG);
 916     return NORMAL;
 917 }
 918
 919 /* Ordinary operators. */
 920
 921 PP(pp_pow)
 922 {
 923     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
 924     {
 925       dPOPTOPnnrl;
 926       SETn( pow( left, right) );
 927       RETURN;
 928     }
 929 }
 930
 931 PP(pp_multiply)
 932 {
 933     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
 934     {
 935       dPOPTOPnnrl;
 936       SETn( left * right );
 937       RETURN;
 938     }
 939 }
 940
 941 PP(pp_divide)
 942 {
 943     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
 944     {
 945       dPOPPOPnnrl;
 946       NV value;
 947       if (right == 0.0)
 948         DIE(aTHX_ "Illegal division by zero");
 949 #ifdef SLOPPYDIVIDE
 950       /* insure that 20./5. == 4. */
 951       {
 952         IV k;
 953         if ((NV)I_V(left)  == left &&
 954             (NV)I_V(right) == right &&
 955             (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
 956             value = k;
 957         }
 958         else {
 959             value = left / right;
 960         }
 961       }
 962 #else
 963       value = left / right;
 964 #endif
 965       PUSHn( value );
 966       RETURN;
 967     }
 968 }
 969
 970 PP(pp_modulo)
 971 {
 972     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
 973     {
 974         UV left;
 975         UV right;
 976         bool left_neg;
 977         bool right_neg;
 978         bool use_double = 0;
 979         NV dright;
 980         NV dleft;
 981
 982         if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 983             IV i = SvIVX(POPs);
 984             right = (right_neg = (i < 0)) ? -i : i;
 985         }
 986         else {
 987             dright = POPn;
 988             use_double = 1;
 989             right_neg = dright < 0;
 990             if (right_neg)
 991                 dright = -dright;
 992         }
 993
 994         if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 995             IV i = SvIVX(POPs);
 996             left = (left_neg = (i < 0)) ? -i : i;
 997         }
 998         else {
 999             dleft = POPn;
1000             if (!use_double) {
1001                 use_double = 1;
1002                 dright = right;
1003             }
1004             left_neg = dleft < 0;
1005             if (left_neg)
1006                 dleft = -dleft;
1007         }
1008
1009         if (use_double) {
1010             NV dans;
1011
1012 #if 1
1013 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1014 #  if CASTFLAGS & 2
1015 #    define CAST_D2UV(d) U_V(d)
1016 #  else
1017 #    define CAST_D2UV(d) ((UV)(d))
1018 #  endif
1019             /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1020              * or, in other words, precision of UV more than of NV.
1021              * But in fact the approach below turned out to be an
1022              * optimization - floor() may be slow */
1023             if (dright <= UV_MAX && dleft <= UV_MAX) {
1024                 right = CAST_D2UV(dright);
1025                 left  = CAST_D2UV(dleft);
1026                 goto do_uv;
1027             }
1028 #endif
1029
1030             /* Backward-compatibility clause: */
1031             dright = floor(dright + 0.5);
1032             dleft  = floor(dleft + 0.5);
1033
1034             if (!dright)
1035                 DIE(aTHX_ "Illegal modulus zero");
1036
1037             dans = Perl_fmod(dleft, dright);
1038             if ((left_neg != right_neg) && dans)
1039                 dans = dright - dans;
1040             if (right_neg)
1041                 dans = -dans;
1042             sv_setnv(TARG, dans);
1043         }
1044         else {
1045             UV ans;
1046
1047         do_uv:
1048             if (!right)
1049                 DIE(aTHX_ "Illegal modulus zero");
1050
1051             ans = left % right;
1052             if ((left_neg != right_neg) && ans)
1053                 ans = right - ans;
1054             if (right_neg) {
1055                 /* XXX may warn: unary minus operator applied to unsigned type */
1056                 /* could change -foo to be (~foo)+1 instead     */
1057                 if (ans <= ~((UV)IV_MAX)+1)
1058                     sv_setiv(TARG, ~ans+1);
1059                 else
1060                     sv_setnv(TARG, -(NV)ans);
1061             }
1062             else
1063                 sv_setuv(TARG, ans);
1064         }
1065         PUSHTARG;
1066         RETURN;
1067     }
1068 }
1069
1070 PP(pp_repeat)
1071 {
1072   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1073   {
1074     register I32 count = POPi;
1075     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1076         dMARK;
1077         I32 items = SP - MARK;
1078         I32 max;
1079
1080         max = items * count;
1081         MEXTEND(MARK, max);
1082         if (count > 1) {
1083             while (SP > MARK) {
1084                 if (*SP)
1085                     SvTEMP_off((*SP));
1086                 SP--;
1087             }
1088             MARK++;
1089             repeatcpy((char*)(MARK + items), (char*)MARK,
1090                 items * sizeof(SV*), count - 1);
1091             SP += max;
1092         }
1093         else if (count <= 0)
1094             SP -= items;
1095     }
1096     else {      /* Note: mark already snarfed by pp_list */
1097         SV *tmpstr;
1098         STRLEN len;
1099
1100         tmpstr = POPs;
1101         SvSetSV(TARG, tmpstr);
1102         SvPV_force(TARG, len);
1103         if (count != 1) {
1104             if (count < 1)
1105                 SvCUR_set(TARG, 0);
1106             else {
1107                 SvGROW(TARG, (count * len) + 1);
1108                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1109                 SvCUR(TARG) *= count;
1110             }
1111             *SvEND(TARG) = '\0';
1112         }
1113         (void)SvPOK_only(TARG);
1114         PUSHTARG;
1115     }
1116     RETURN;
1117   }
1118 }
1119
1120 PP(pp_subtract)
1121 {
1122     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1123     {
1124       dPOPTOPnnrl_ul;
1125       SETn( left - right );
1126       RETURN;
1127     }
1128 }
1129
1130 PP(pp_left_shift)
1131 {
1132     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1133     {
1134       IBW shift = POPi;
1135       if (PL_op->op_private & HINT_INTEGER) {
1136         IBW i = TOPi;
1137         i = BWi(i) << shift;
1138         SETi(BWi(i));
1139       }
1140       else {
1141         UBW u = TOPu;
1142         u <<= shift;
1143         SETu(BWu(u));
1144       }
1145       RETURN;
1146     }
1147 }
1148
1149 PP(pp_right_shift)
1150 {
1151     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1152     {
1153       IBW shift = POPi;
1154       if (PL_op->op_private & HINT_INTEGER) {
1155         IBW i = TOPi;
1156         i = BWi(i) >> shift;
1157         SETi(BWi(i));
1158       }
1159       else {
1160         UBW u = TOPu;
1161         u >>= shift;
1162         SETu(BWu(u));
1163       }
1164       RETURN;
1165     }
1166 }
1167
1168 PP(pp_lt)
1169 {
1170     djSP; tryAMAGICbinSET(lt,0);
1171     {
1172       dPOPnv;
1173       SETs(boolSV(TOPn < value));
1174       RETURN;
1175     }
1176 }
1177
1178 PP(pp_gt)
1179 {
1180     djSP; tryAMAGICbinSET(gt,0);
1181     {
1182       dPOPnv;
1183       SETs(boolSV(TOPn > value));
1184       RETURN;
1185     }
1186 }
1187
1188 PP(pp_le)
1189 {
1190     djSP; tryAMAGICbinSET(le,0);
1191     {
1192       dPOPnv;
1193       SETs(boolSV(TOPn <= value));
1194       RETURN;
1195     }
1196 }
1197
1198 PP(pp_ge)
1199 {
1200     djSP; tryAMAGICbinSET(ge,0);
1201     {
1202       dPOPnv;
1203       SETs(boolSV(TOPn >= value));
1204       RETURN;
1205     }
1206 }
1207
1208 PP(pp_ne)
1209 {
1210     djSP; tryAMAGICbinSET(ne,0);
1211     {
1212       dPOPnv;
1213       SETs(boolSV(TOPn != value));
1214       RETURN;
1215     }
1216 }
1217
1218 PP(pp_ncmp)
1219 {
1220     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1221     {
1222       dPOPTOPnnrl;
1223       I32 value;
1224
1225       if (left == right)
1226         value = 0;
1227       else if (left < right)
1228         value = -1;
1229       else if (left > right)
1230         value = 1;
1231       else {
1232         SETs(&PL_sv_undef);
1233         RETURN;
1234       }
1235       SETi(value);
1236       RETURN;
1237     }
1238 }
1239
1240 PP(pp_slt)
1241 {
1242     djSP; tryAMAGICbinSET(slt,0);
1243     {
1244       dPOPTOPssrl;
1245       int cmp = ((PL_op->op_private & OPpLOCALE)
1246                  ? sv_cmp_locale(left, right)
1247                  : sv_cmp(left, right));
1248       SETs(boolSV(cmp < 0));
1249       RETURN;
1250     }
1251 }
1252
1253 PP(pp_sgt)
1254 {
1255     djSP; tryAMAGICbinSET(sgt,0);
1256     {
1257       dPOPTOPssrl;
1258       int cmp = ((PL_op->op_private & OPpLOCALE)
1259                  ? sv_cmp_locale(left, right)
1260                  : sv_cmp(left, right));
1261       SETs(boolSV(cmp > 0));
1262       RETURN;
1263     }
1264 }
1265
1266 PP(pp_sle)
1267 {
1268     djSP; tryAMAGICbinSET(sle,0);
1269     {
1270       dPOPTOPssrl;
1271       int cmp = ((PL_op->op_private & OPpLOCALE)
1272                  ? sv_cmp_locale(left, right)
1273                  : sv_cmp(left, right));
1274       SETs(boolSV(cmp <= 0));
1275       RETURN;
1276     }
1277 }
1278
1279 PP(pp_sge)
1280 {
1281     djSP; tryAMAGICbinSET(sge,0);
1282     {
1283       dPOPTOPssrl;
1284       int cmp = ((PL_op->op_private & OPpLOCALE)
1285                  ? sv_cmp_locale(left, right)
1286                  : sv_cmp(left, right));
1287       SETs(boolSV(cmp >= 0));
1288       RETURN;
1289     }
1290 }
1291
1292 PP(pp_seq)
1293 {
1294     djSP; tryAMAGICbinSET(seq,0);
1295     {
1296       dPOPTOPssrl;
1297       SETs(boolSV(sv_eq(left, right)));
1298       RETURN;
1299     }
1300 }
1301
1302 PP(pp_sne)
1303 {
1304     djSP; tryAMAGICbinSET(sne,0);
1305     {
1306       dPOPTOPssrl;
1307       SETs(boolSV(!sv_eq(left, right)));
1308       RETURN;
1309     }
1310 }
1311
1312 PP(pp_scmp)
1313 {
1314     djSP; dTARGET;  tryAMAGICbin(scmp,0);
1315     {
1316       dPOPTOPssrl;
1317       int cmp = ((PL_op->op_private & OPpLOCALE)
1318                  ? sv_cmp_locale(left, right)
1319                  : sv_cmp(left, right));
1320       SETi( cmp );
1321       RETURN;
1322     }
1323 }
1324
1325 PP(pp_bit_and)
1326 {
1327     djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1328     {
1329       dPOPTOPssrl;
1330       if (SvNIOKp(left) || SvNIOKp(right)) {
1331         if (PL_op->op_private & HINT_INTEGER) {
1332           IBW value = SvIV(left) & SvIV(right);
1333           SETi(BWi(value));
1334         }
1335         else {
1336           UBW value = SvUV(left) & SvUV(right);
1337           SETu(BWu(value));
1338         }
1339       }
1340       else {
1341         do_vop(PL_op->op_type, TARG, left, right);
1342         SETTARG;
1343       }
1344       RETURN;
1345     }
1346 }
1347
1348 PP(pp_bit_xor)
1349 {
1350     djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1351     {
1352       dPOPTOPssrl;
1353       if (SvNIOKp(left) || SvNIOKp(right)) {
1354         if (PL_op->op_private & HINT_INTEGER) {
1355           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1356           SETi(BWi(value));
1357         }
1358         else {
1359           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1360           SETu(BWu(value));
1361         }
1362       }
1363       else {
1364         do_vop(PL_op->op_type, TARG, left, right);
1365         SETTARG;
1366       }
1367       RETURN;
1368     }
1369 }
1370
1371 PP(pp_bit_or)
1372 {
1373     djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1374     {
1375       dPOPTOPssrl;
1376       if (SvNIOKp(left) || SvNIOKp(right)) {
1377         if (PL_op->op_private & HINT_INTEGER) {
1378           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1379           SETi(BWi(value));
1380         }
1381         else {
1382           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1383           SETu(BWu(value));
1384         }
1385       }
1386       else {
1387         do_vop(PL_op->op_type, TARG, left, right);
1388         SETTARG;
1389       }
1390       RETURN;
1391     }
1392 }
1393
1394 PP(pp_negate)
1395 {
1396     djSP; dTARGET; tryAMAGICun(neg);
1397     {
1398         dTOPss;
1399         if (SvGMAGICAL(sv))
1400             mg_get(sv);
1401         if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1402             SETi(-SvIVX(sv));
1403         else if (SvNIOKp(sv))
1404             SETn(-SvNV(sv));
1405         else if (SvPOKp(sv)) {
1406             STRLEN len;
1407             char *s = SvPV(sv, len);
1408             if (isIDFIRST(*s)) {
1409                 sv_setpvn(TARG, "-", 1);
1410                 sv_catsv(TARG, sv);
1411             }
1412             else if (*s == '+' || *s == '-') {
1413                 sv_setsv(TARG, sv);
1414                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1415             }
1416             else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1417                 sv_setpvn(TARG, "-", 1);
1418                 sv_catsv(TARG, sv);
1419             }
1420             else
1421                 sv_setnv(TARG, -SvNV(sv));
1422             SETTARG;
1423         }
1424         else
1425             SETn(-SvNV(sv));
1426     }
1427     RETURN;
1428 }
1429
1430 PP(pp_not)
1431 {
1432     djSP; tryAMAGICunSET(not);
1433     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1434     return NORMAL;
1435 }
1436
1437 PP(pp_complement)
1438 {
1439     djSP; dTARGET; tryAMAGICun(compl);
1440     {
1441       dTOPss;
1442       if (SvNIOKp(sv)) {
1443         if (PL_op->op_private & HINT_INTEGER) {
1444           IBW value = ~SvIV(sv);
1445           SETi(BWi(value));
1446         }
1447         else {
1448           UBW value = ~SvUV(sv);
1449           SETu(BWu(value));
1450         }
1451       }
1452       else {
1453         register char *tmps;
1454         register long *tmpl;
1455         register I32 anum;
1456         STRLEN len;
1457
1458         SvSetSV(TARG, sv);
1459         tmps = SvPV_force(TARG, len);
1460         anum = len;
1461 #ifdef LIBERAL
1462         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1463             *tmps = ~*tmps;
1464         tmpl = (long*)tmps;
1465         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1466             *tmpl = ~*tmpl;
1467         tmps = (char*)tmpl;
1468 #endif
1469         for ( ; anum > 0; anum--, tmps++)
1470             *tmps = ~*tmps;
1471
1472         SETs(TARG);
1473       }
1474       RETURN;
1475     }
1476 }
1477
1478 /* integer versions of some of the above */
1479
1480 PP(pp_i_multiply)
1481 {
1482     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1483     {
1484       dPOPTOPiirl;
1485       SETi( left * right );
1486       RETURN;
1487     }
1488 }
1489
1490 PP(pp_i_divide)
1491 {
1492     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1493     {
1494       dPOPiv;
1495       if (value == 0)
1496         DIE(aTHX_ "Illegal division by zero");
1497       value = POPi / value;
1498       PUSHi( value );
1499       RETURN;
1500     }
1501 }
1502
1503 PP(pp_i_modulo)
1504 {
1505     djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1506     {
1507       dPOPTOPiirl;
1508       if (!right)
1509         DIE(aTHX_ "Illegal modulus zero");
1510       SETi( left % right );
1511       RETURN;
1512     }
1513 }
1514
1515 PP(pp_i_add)
1516 {
1517     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1518     {
1519       dPOPTOPiirl;
1520       SETi( left + right );
1521       RETURN;
1522     }
1523 }
1524
1525 PP(pp_i_subtract)
1526 {
1527     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1528     {
1529       dPOPTOPiirl;
1530       SETi( left - right );
1531       RETURN;
1532     }
1533 }
1534
1535 PP(pp_i_lt)
1536 {
1537     djSP; tryAMAGICbinSET(lt,0);
1538     {
1539       dPOPTOPiirl;
1540       SETs(boolSV(left < right));
1541       RETURN;
1542     }
1543 }
1544
1545 PP(pp_i_gt)
1546 {
1547     djSP; tryAMAGICbinSET(gt,0);
1548     {
1549       dPOPTOPiirl;
1550       SETs(boolSV(left > right));
1551       RETURN;
1552     }
1553 }
1554
1555 PP(pp_i_le)
1556 {
1557     djSP; tryAMAGICbinSET(le,0);
1558     {
1559       dPOPTOPiirl;
1560       SETs(boolSV(left <= right));
1561       RETURN;
1562     }
1563 }
1564
1565 PP(pp_i_ge)
1566 {
1567     djSP; tryAMAGICbinSET(ge,0);
1568     {
1569       dPOPTOPiirl;
1570       SETs(boolSV(left >= right));
1571       RETURN;
1572     }
1573 }
1574
1575 PP(pp_i_eq)
1576 {
1577     djSP; tryAMAGICbinSET(eq,0);
1578     {
1579       dPOPTOPiirl;
1580       SETs(boolSV(left == right));
1581       RETURN;
1582     }
1583 }
1584
1585 PP(pp_i_ne)
1586 {
1587     djSP; tryAMAGICbinSET(ne,0);
1588     {
1589       dPOPTOPiirl;
1590       SETs(boolSV(left != right));
1591       RETURN;
1592     }
1593 }
1594
1595 PP(pp_i_ncmp)
1596 {
1597     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1598     {
1599       dPOPTOPiirl;
1600       I32 value;
1601
1602       if (left > right)
1603         value = 1;
1604       else if (left < right)
1605         value = -1;
1606       else
1607         value = 0;
1608       SETi(value);
1609       RETURN;
1610     }
1611 }
1612
1613 PP(pp_i_negate)
1614 {
1615     djSP; dTARGET; tryAMAGICun(neg);
1616     SETi(-TOPi);
1617     RETURN;
1618 }
1619
1620 /* High falutin' math. */
1621
1622 PP(pp_atan2)
1623 {
1624     djSP; dTARGET; tryAMAGICbin(atan2,0);
1625     {
1626       dPOPTOPnnrl;
1627       SETn(Perl_atan2(left, right));
1628       RETURN;
1629     }
1630 }
1631
1632 PP(pp_sin)
1633 {
1634     djSP; dTARGET; tryAMAGICun(sin);
1635     {
1636       NV value;
1637       value = POPn;
1638       value = Perl_sin(value);
1639       XPUSHn(value);
1640       RETURN;
1641     }
1642 }
1643
1644 PP(pp_cos)
1645 {
1646     djSP; dTARGET; tryAMAGICun(cos);
1647     {
1648       NV value;
1649       value = POPn;
1650       value = Perl_cos(value);
1651       XPUSHn(value);
1652       RETURN;
1653     }
1654 }
1655
1656 /* Support Configure command-line overrides for rand() functions.
1657    After 5.005, perhaps we should replace this by Configure support
1658    for drand48(), random(), or rand().  For 5.005, though, maintain
1659    compatibility by calling rand() but allow the user to override it.
1660    See INSTALL for details.  --Andy Dougherty  15 July 1998
1661 */
1662 /* Now it's after 5.005, and Configure supports drand48() and random(),
1663    in addition to rand().  So the overrides should not be needed any more.
1664    --Jarkko Hietaniemi  27 September 1998
1665  */
1666
1667 #ifndef HAS_DRAND48_PROTO
1668 extern double drand48 (void);
1669 #endif
1670
1671 PP(pp_rand)
1672 {
1673     djSP; dTARGET;
1674     NV value;
1675     if (MAXARG < 1)
1676         value = 1.0;
1677     else
1678         value = POPn;
1679     if (value == 0.0)
1680         value = 1.0;
1681     if (!PL_srand_called) {
1682         (void)seedDrand01((Rand_seed_t)seed());
1683         PL_srand_called = TRUE;
1684     }
1685     value *= Drand01();
1686     XPUSHn(value);
1687     RETURN;
1688 }
1689
1690 PP(pp_srand)
1691 {
1692     djSP;
1693     UV anum;
1694     if (MAXARG < 1)
1695         anum = seed();
1696     else
1697         anum = POPu;
1698     (void)seedDrand01((Rand_seed_t)anum);
1699     PL_srand_called = TRUE;
1700     EXTEND(SP, 1);
1701     RETPUSHYES;
1702 }
1703
1704 STATIC U32
1705 S_seed(pTHX)
1706 {
1707     /*
1708      * This is really just a quick hack which grabs various garbage
1709      * values.  It really should be a real hash algorithm which
1710      * spreads the effect of every input bit onto every output bit,
1711      * if someone who knows about such things would bother to write it.
1712      * Might be a good idea to add that function to CORE as well.
1713      * No numbers below come from careful analysis or anything here,
1714      * except they are primes and SEED_C1 > 1E6 to get a full-width
1715      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1716      * probably be bigger too.
1717      */
1718 #if RANDBITS > 16
1719 #  define SEED_C1       1000003
1720 #define   SEED_C4       73819
1721 #else
1722 #  define SEED_C1       25747
1723 #define   SEED_C4       20639
1724 #endif
1725 #define   SEED_C2       3
1726 #define   SEED_C3       269
1727 #define   SEED_C5       26107
1728
1729     dTHR;
1730 #ifndef PERL_NO_DEV_RANDOM
1731     int fd;
1732 #endif
1733     U32 u;
1734 #ifdef VMS
1735 #  include <starlet.h>
1736     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1737      * in 100-ns units, typically incremented ever 10 ms.        */
1738     unsigned int when[2];
1739 #else
1740 #  ifdef HAS_GETTIMEOFDAY
1741     struct timeval when;
1742 #  else
1743     Time_t when;
1744 #  endif
1745 #endif
1746
1747 /* This test is an escape hatch, this symbol isn't set by Configure. */
1748 #ifndef PERL_NO_DEV_RANDOM
1749 #ifndef PERL_RANDOM_DEVICE
1750    /* /dev/random isn't used by default because reads from it will block
1751     * if there isn't enough entropy available.  You can compile with
1752     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1753     * is enough real entropy to fill the seed. */
1754 #  define PERL_RANDOM_DEVICE "/dev/urandom"
1755 #endif
1756     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1757     if (fd != -1) {
1758         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1759             u = 0;
1760         PerlLIO_close(fd);
1761         if (u)
1762             return u;
1763     }
1764 #endif
1765
1766 #ifdef VMS
1767     _ckvmssts(sys$gettim(when));
1768     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1769 #else
1770 #  ifdef HAS_GETTIMEOFDAY
1771     gettimeofday(&when,(struct timezone *) 0);
1772     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1773 #  else
1774     (void)time(&when);
1775     u = (U32)SEED_C1 * when;
1776 #  endif
1777 #endif
1778     u += SEED_C3 * (U32)getpid();
1779     u += SEED_C4 * (U32)(UV)PL_stack_sp;
1780 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1781     u += SEED_C5 * (U32)(UV)&when;
1782 #endif
1783     return u;
1784 }
1785
1786 PP(pp_exp)
1787 {
1788     djSP; dTARGET; tryAMAGICun(exp);
1789     {
1790       NV value;
1791       value = POPn;
1792       value = Perl_exp(value);
1793       XPUSHn(value);
1794       RETURN;
1795     }
1796 }
1797
1798 PP(pp_log)
1799 {
1800     djSP; dTARGET; tryAMAGICun(log);
1801     {
1802       NV value;
1803       value = POPn;
1804       if (value <= 0.0) {
1805         RESTORE_NUMERIC_STANDARD();
1806         DIE(aTHX_ "Can't take log of %g", value);
1807       }
1808       value = Perl_log(value);
1809       XPUSHn(value);
1810       RETURN;
1811     }
1812 }
1813
1814 PP(pp_sqrt)
1815 {
1816     djSP; dTARGET; tryAMAGICun(sqrt);
1817     {
1818       NV value;
1819       value = POPn;
1820       if (value < 0.0) {
1821         RESTORE_NUMERIC_STANDARD();
1822         DIE(aTHX_ "Can't take sqrt of %g", value);
1823       }
1824       value = Perl_sqrt(value);
1825       XPUSHn(value);
1826       RETURN;
1827     }
1828 }
1829
1830 PP(pp_int)
1831 {
1832     djSP; dTARGET;
1833     {
1834       NV value = TOPn;
1835       IV iv;
1836
1837       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1838         iv = SvIVX(TOPs);
1839         SETi(iv);
1840       }
1841       else {
1842         if (value >= 0.0)
1843           (void)Perl_modf(value, &value);
1844         else {
1845           (void)Perl_modf(-value, &value);
1846           value = -value;
1847         }
1848         iv = I_V(value);
1849         if (iv == value)
1850           SETi(iv);
1851         else
1852           SETn(value);
1853       }
1854     }
1855     RETURN;
1856 }
1857
1858 PP(pp_abs)
1859 {
1860     djSP; dTARGET; tryAMAGICun(abs);
1861     {
1862       NV value = TOPn;
1863       IV iv;
1864
1865       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1866           (iv = SvIVX(TOPs)) != IV_MIN) {
1867         if (iv < 0)
1868           iv = -iv;
1869         SETi(iv);
1870       }
1871       else {
1872         if (value < 0.0)
1873             value = -value;
1874         SETn(value);
1875       }
1876     }
1877     RETURN;
1878 }
1879
1880 PP(pp_hex)
1881 {
1882     djSP; dTARGET;
1883     char *tmps;
1884     I32 argtype;
1885     STRLEN n_a;
1886
1887     tmps = POPpx;
1888     XPUSHu(scan_hex(tmps, 99, &argtype));
1889     RETURN;
1890 }
1891
1892 PP(pp_oct)
1893 {
1894     djSP; dTARGET;
1895     UV value;
1896     I32 argtype;
1897     char *tmps;
1898     STRLEN n_a;
1899
1900     tmps = POPpx;
1901     while (*tmps && isSPACE(*tmps))
1902         tmps++;
1903     if (*tmps == '0')
1904         tmps++;
1905     if (*tmps == 'x')
1906         value = scan_hex(++tmps, 99, &argtype);
1907     else if (*tmps == 'b')
1908         value = scan_bin(++tmps, 99, &argtype);
1909     else
1910         value = scan_oct(tmps, 99, &argtype);
1911     XPUSHu(value);
1912     RETURN;
1913 }
1914
1915 /* String stuff. */
1916
1917 PP(pp_length)
1918 {
1919     djSP; dTARGET;
1920
1921     if (IN_UTF8) {
1922         SETi( sv_len_utf8(TOPs) );
1923         RETURN;
1924     }
1925
1926     SETi( sv_len(TOPs) );
1927     RETURN;
1928 }
1929
1930 PP(pp_substr)
1931 {
1932     djSP; dTARGET;
1933     SV *sv;
1934     I32 len;
1935     STRLEN curlen;
1936     STRLEN utfcurlen;
1937     I32 pos;
1938     I32 rem;
1939     I32 fail;
1940     I32 lvalue = PL_op->op_flags & OPf_MOD;
1941     char *tmps;
1942     I32 arybase = PL_curcop->cop_arybase;
1943     char *repl = 0;
1944     STRLEN repl_len;
1945
1946     SvTAINTED_off(TARG);                        /* decontaminate */
1947     if (MAXARG > 2) {
1948         if (MAXARG > 3) {
1949             sv = POPs;
1950             repl = SvPV(sv, repl_len);
1951         }
1952         len = POPi;
1953     }
1954     pos = POPi;
1955     sv = POPs;
1956     PUTBACK;
1957     tmps = SvPV(sv, curlen);
1958     if (IN_UTF8) {
1959         utfcurlen = sv_len_utf8(sv);
1960         if (utfcurlen == curlen)
1961             utfcurlen = 0;
1962         else
1963             curlen = utfcurlen;
1964     }
1965     else
1966         utfcurlen = 0;
1967
1968     if (pos >= arybase) {
1969         pos -= arybase;
1970         rem = curlen-pos;
1971         fail = rem;
1972         if (MAXARG > 2) {
1973             if (len < 0) {
1974                 rem += len;
1975                 if (rem < 0)
1976                     rem = 0;
1977             }
1978             else if (rem > len)
1979                      rem = len;
1980         }
1981     }
1982     else {
1983         pos += curlen;
1984         if (MAXARG < 3)
1985             rem = curlen;
1986         else if (len >= 0) {
1987             rem = pos+len;
1988             if (rem > (I32)curlen)
1989                 rem = curlen;
1990         }
1991         else {
1992             rem = curlen+len;
1993             if (rem < pos)
1994                 rem = pos;
1995         }
1996         if (pos < 0)
1997             pos = 0;
1998         fail = rem;
1999         rem -= pos;
2000     }
2001     if (fail < 0) {
2002         if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2003             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2004         RETPUSHUNDEF;
2005     }
2006     else {
2007         if (utfcurlen)
2008             sv_pos_u2b(sv, &pos, &rem);
2009         tmps += pos;
2010         sv_setpvn(TARG, tmps, rem);
2011         if (lvalue) {                   /* it's an lvalue! */
2012             if (!SvGMAGICAL(sv)) {
2013                 if (SvROK(sv)) {
2014                     STRLEN n_a;
2015                     SvPV_force(sv,n_a);
2016                     if (ckWARN(WARN_SUBSTR))
2017                         Perl_warner(aTHX_ WARN_SUBSTR,
2018                                 "Attempt to use reference as lvalue in substr");
2019                 }
2020                 if (SvOK(sv))           /* is it defined ? */
2021                     (void)SvPOK_only(sv);
2022                 else
2023                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2024             }
2025
2026             if (SvTYPE(TARG) < SVt_PVLV) {
2027                 sv_upgrade(TARG, SVt_PVLV);
2028                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2029             }
2030
2031             LvTYPE(TARG) = 'x';
2032             if (LvTARG(TARG) != sv) {
2033                 if (LvTARG(TARG))
2034                     SvREFCNT_dec(LvTARG(TARG));
2035                 LvTARG(TARG) = SvREFCNT_inc(sv);
2036             }
2037             LvTARGOFF(TARG) = pos;
2038             LvTARGLEN(TARG) = rem;
2039         }
2040         else if (repl)
2041             sv_insert(sv, pos, rem, repl, repl_len);
2042     }
2043     SPAGAIN;
2044     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2045     RETURN;
2046 }
2047
2048 PP(pp_vec)
2049 {
2050     djSP; dTARGET;
2051     register I32 size = POPi;
2052     register I32 offset = POPi;
2053     register SV *src = POPs;
2054     I32 lvalue = PL_op->op_flags & OPf_MOD;
2055     STRLEN srclen;
2056     unsigned char *s = (unsigned char*)SvPV(src, srclen);
2057     unsigned long retnum;
2058     I32 len;
2059
2060     SvTAINTED_off(TARG);                        /* decontaminate */
2061     offset *= size;             /* turn into bit offset */
2062     len = (offset + size + 7) / 8;
2063     if (offset < 0 || size < 1)
2064         retnum = 0;
2065     else {
2066         if (lvalue) {                      /* it's an lvalue! */
2067             if (SvTYPE(TARG) < SVt_PVLV) {
2068                 sv_upgrade(TARG, SVt_PVLV);
2069                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2070             }
2071
2072             LvTYPE(TARG) = 'v';
2073             if (LvTARG(TARG) != src) {
2074                 if (LvTARG(TARG))
2075                     SvREFCNT_dec(LvTARG(TARG));
2076                 LvTARG(TARG) = SvREFCNT_inc(src);
2077             }
2078             LvTARGOFF(TARG) = offset;
2079             LvTARGLEN(TARG) = size;
2080         }
2081         if (len > srclen) {
2082             if (size <= 8)
2083                 retnum = 0;
2084             else {
2085                 offset >>= 3;
2086                 if (size == 16) {
2087                     if (offset >= srclen)
2088                         retnum = 0;
2089                     else
2090                         retnum = (unsigned long) s[offset] << 8;
2091                 }
2092                 else if (size == 32) {
2093                     if (offset >= srclen)
2094                         retnum = 0;
2095                     else if (offset + 1 >= srclen)
2096                         retnum = (unsigned long) s[offset] << 24;
2097                     else if (offset + 2 >= srclen)
2098                         retnum = ((unsigned long) s[offset] << 24) +
2099                             ((unsigned long) s[offset + 1] << 16);
2100                     else
2101                         retnum = ((unsigned long) s[offset] << 24) +
2102                             ((unsigned long) s[offset + 1] << 16) +
2103                             (s[offset + 2] << 8);
2104                 }
2105             }
2106         }
2107         else if (size < 8)
2108             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2109         else {
2110             offset >>= 3;
2111             if (size == 8)
2112                 retnum = s[offset];
2113             else if (size == 16)
2114                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2115             else if (size == 32)
2116                 retnum = ((unsigned long) s[offset] << 24) +
2117                         ((unsigned long) s[offset + 1] << 16) +
2118                         (s[offset + 2] << 8) + s[offset+3];
2119         }
2120     }
2121
2122     sv_setuv(TARG, (UV)retnum);
2123     PUSHs(TARG);
2124     RETURN;
2125 }
2126
2127 PP(pp_index)
2128 {
2129     djSP; dTARGET;
2130     SV *big;
2131     SV *little;
2132     I32 offset;
2133     I32 retval;
2134     char *tmps;
2135     char *tmps2;
2136     STRLEN biglen;
2137     I32 arybase = PL_curcop->cop_arybase;
2138
2139     if (MAXARG < 3)
2140         offset = 0;
2141     else
2142         offset = POPi - arybase;
2143     little = POPs;
2144     big = POPs;
2145     tmps = SvPV(big, biglen);
2146     if (IN_UTF8 && offset > 0)
2147         sv_pos_u2b(big, &offset, 0);
2148     if (offset < 0)
2149         offset = 0;
2150     else if (offset > biglen)
2151         offset = biglen;
2152     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2153       (unsigned char*)tmps + biglen, little, 0)))
2154         retval = -1;
2155     else
2156         retval = tmps2 - tmps;
2157     if (IN_UTF8 && retval > 0)
2158         sv_pos_b2u(big, &retval);
2159     PUSHi(retval + arybase);
2160     RETURN;
2161 }
2162
2163 PP(pp_rindex)
2164 {
2165     djSP; dTARGET;
2166     SV *big;
2167     SV *little;
2168     STRLEN blen;
2169     STRLEN llen;
2170     I32 offset;
2171     I32 retval;
2172     char *tmps;
2173     char *tmps2;
2174     I32 arybase = PL_curcop->cop_arybase;
2175
2176     if (MAXARG >= 3)
2177         offset = POPi;
2178     little = POPs;
2179     big = POPs;
2180     tmps2 = SvPV(little, llen);
2181     tmps = SvPV(big, blen);
2182     if (MAXARG < 3)
2183         offset = blen;
2184     else {
2185         if (IN_UTF8 && offset > 0)
2186             sv_pos_u2b(big, &offset, 0);
2187         offset = offset - arybase + llen;
2188     }
2189     if (offset < 0)
2190         offset = 0;
2191     else if (offset > blen)
2192         offset = blen;
2193     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2194                           tmps2, tmps2 + llen)))
2195         retval = -1;
2196     else
2197         retval = tmps2 - tmps;
2198     if (IN_UTF8 && retval > 0)
2199         sv_pos_b2u(big, &retval);
2200     PUSHi(retval + arybase);
2201     RETURN;
2202 }
2203
2204 PP(pp_sprintf)
2205 {
2206     djSP; dMARK; dORIGMARK; dTARGET;
2207     do_sprintf(TARG, SP-MARK, MARK+1);
2208     TAINT_IF(SvTAINTED(TARG));
2209     SP = ORIGMARK;
2210     PUSHTARG;
2211     RETURN;
2212 }
2213
2214 PP(pp_ord)
2215 {
2216     djSP; dTARGET;
2217     UV value;
2218     STRLEN n_a;
2219     U8 *tmps = (U8*)POPpx;
2220     I32 retlen;
2221
2222     if (IN_UTF8 && (*tmps & 0x80))
2223         value = utf8_to_uv(tmps, &retlen);
2224     else
2225         value = (UV)(*tmps & 255);
2226     XPUSHu(value);
2227     RETURN;
2228 }
2229
2230 PP(pp_chr)
2231 {
2232     djSP; dTARGET;
2233     char *tmps;
2234     U32 value = POPu;
2235
2236     (void)SvUPGRADE(TARG,SVt_PV);
2237
2238     if (IN_UTF8 && value >= 128) {
2239         SvGROW(TARG,8);
2240         tmps = SvPVX(TARG);
2241         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2242         SvCUR_set(TARG, tmps - SvPVX(TARG));
2243         *tmps = '\0';
2244         (void)SvPOK_only(TARG);
2245         XPUSHs(TARG);
2246         RETURN;
2247     }
2248
2249     SvGROW(TARG,2);
2250     SvCUR_set(TARG, 1);
2251     tmps = SvPVX(TARG);
2252     *tmps++ = value;
2253     *tmps = '\0';
2254     (void)SvPOK_only(TARG);
2255     XPUSHs(TARG);
2256     RETURN;
2257 }
2258
2259 PP(pp_crypt)
2260 {
2261     djSP; dTARGET; dPOPTOPssrl;
2262     STRLEN n_a;
2263 #ifdef HAS_CRYPT
2264     char *tmps = SvPV(left, n_a);
2265 #ifdef FCRYPT
2266     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2267 #else
2268     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2269 #endif
2270 #else
2271     DIE(aTHX_
2272       "The crypt() function is unimplemented due to excessive paranoia.");
2273 #endif
2274     SETs(TARG);
2275     RETURN;
2276 }
2277
2278 PP(pp_ucfirst)
2279 {
2280     djSP;
2281     SV *sv = TOPs;
2282     register U8 *s;
2283     STRLEN slen;
2284
2285     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2286         I32 ulen;
2287         U8 tmpbuf[10];
2288         U8 *tend;
2289         UV uv = utf8_to_uv(s, &ulen);
2290
2291         if (PL_op->op_private & OPpLOCALE) {
2292             TAINT;
2293             SvTAINTED_on(sv);
2294             uv = toTITLE_LC_uni(uv);
2295         }
2296         else
2297             uv = toTITLE_utf8(s);
2298
2299         tend = uv_to_utf8(tmpbuf, uv);
2300
2301         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2302             dTARGET;
2303             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2304             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2305             SETs(TARG);
2306         }
2307         else {
2308             s = (U8*)SvPV_force(sv, slen);
2309             Copy(tmpbuf, s, ulen, U8);
2310         }
2311     } else {
2312         if (!SvPADTMP(sv)) {
2313             dTARGET;
2314             sv_setsv(TARG, sv);
2315             sv = TARG;
2316             SETs(sv);
2317         }
2318         s = (U8*)SvPV_force(sv, slen);
2319         if (*s) {
2320             if (PL_op->op_private & OPpLOCALE) {
2321                 TAINT;
2322                 SvTAINTED_on(sv);
2323                 *s = toUPPER_LC(*s);
2324             }
2325             else
2326                 *s = toUPPER(*s);
2327         }
2328     }
2329     if (SvSMAGICAL(sv))
2330         mg_set(sv);
2331     RETURN;
2332 }
2333
2334 PP(pp_lcfirst)
2335 {
2336     djSP;
2337     SV *sv = TOPs;
2338     register U8 *s;
2339     STRLEN slen;
2340
2341     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2342         I32 ulen;
2343         U8 tmpbuf[10];
2344         U8 *tend;
2345         UV uv = utf8_to_uv(s, &ulen);
2346
2347         if (PL_op->op_private & OPpLOCALE) {
2348             TAINT;
2349             SvTAINTED_on(sv);
2350             uv = toLOWER_LC_uni(uv);
2351         }
2352         else
2353             uv = toLOWER_utf8(s);
2354
2355         tend = uv_to_utf8(tmpbuf, uv);
2356
2357         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2358             dTARGET;
2359             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2360             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2361             SETs(TARG);
2362         }
2363         else {
2364             s = (U8*)SvPV_force(sv, slen);
2365             Copy(tmpbuf, s, ulen, U8);
2366         }
2367     } else {
2368         if (!SvPADTMP(sv)) {
2369             dTARGET;
2370             sv_setsv(TARG, sv);
2371             sv = TARG;
2372             SETs(sv);
2373         }
2374         s = (U8*)SvPV_force(sv, slen);
2375         if (*s) {
2376             if (PL_op->op_private & OPpLOCALE) {
2377                 TAINT;
2378                 SvTAINTED_on(sv);
2379                 *s = toLOWER_LC(*s);
2380             }
2381             else
2382                 *s = toLOWER(*s);
2383         }
2384         SETs(sv);
2385     }
2386     if (SvSMAGICAL(sv))
2387         mg_set(sv);
2388     RETURN;
2389 }
2390
2391 PP(pp_uc)
2392 {
2393     djSP;
2394     SV *sv = TOPs;
2395     register U8 *s;
2396     STRLEN len;
2397
2398     if (IN_UTF8) {
2399         dTARGET;
2400         I32 ulen;
2401         register U8 *d;
2402         U8 *send;
2403
2404         s = (U8*)SvPV(sv,len);
2405         if (!len) {
2406             sv_setpvn(TARG, "", 0);
2407             SETs(TARG);
2408         } else {
2409             (void)SvUPGRADE(TARG, SVt_PV);
2410             SvGROW(TARG, (len * 2) + 1);
2411             (void)SvPOK_only(TARG);
2412             d = (U8*)SvPVX(TARG);
2413             send = s + len;
2414             if (PL_op->op_private & OPpLOCALE) {
2415                 TAINT;
2416                 SvTAINTED_on(TARG);
2417                 while (s < send) {
2418                     d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2419                     s += ulen;
2420                 }
2421             }
2422             else {
2423                 while (s < send) {
2424                     d = uv_to_utf8(d, toUPPER_utf8( s ));
2425                     s += UTF8SKIP(s);
2426                 }
2427             }
2428             *d = '\0';
2429             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2430             SETs(TARG);
2431         }
2432     } else {
2433         if (!SvPADTMP(sv)) {
2434             dTARGET;
2435             sv_setsv(TARG, sv);
2436             sv = TARG;
2437             SETs(sv);
2438         }
2439         s = (U8*)SvPV_force(sv, len);
2440         if (len) {
2441             register U8 *send = s + len;
2442
2443             if (PL_op->op_private & OPpLOCALE) {
2444                 TAINT;
2445                 SvTAINTED_on(sv);
2446                 for (; s < send; s++)
2447                     *s = toUPPER_LC(*s);
2448             }
2449             else {
2450                 for (; s < send; s++)
2451                     *s = toUPPER(*s);
2452             }
2453         }
2454     }
2455     if (SvSMAGICAL(sv))
2456         mg_set(sv);
2457     RETURN;
2458 }
2459
2460 PP(pp_lc)
2461 {
2462     djSP;
2463     SV *sv = TOPs;
2464     register U8 *s;
2465     STRLEN len;
2466
2467     if (IN_UTF8) {
2468         dTARGET;
2469         I32 ulen;
2470         register U8 *d;
2471         U8 *send;
2472
2473         s = (U8*)SvPV(sv,len);
2474         if (!len) {
2475             sv_setpvn(TARG, "", 0);
2476             SETs(TARG);
2477         } else {
2478             (void)SvUPGRADE(TARG, SVt_PV);
2479             SvGROW(TARG, (len * 2) + 1);
2480             (void)SvPOK_only(TARG);
2481             d = (U8*)SvPVX(TARG);
2482             send = s + len;
2483             if (PL_op->op_private & OPpLOCALE) {
2484                 TAINT;
2485                 SvTAINTED_on(TARG);
2486                 while (s < send) {
2487                     d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2488                     s += ulen;
2489                 }
2490             }
2491             else {
2492                 while (s < send) {
2493                     d = uv_to_utf8(d, toLOWER_utf8(s));
2494                     s += UTF8SKIP(s);
2495                 }
2496             }
2497             *d = '\0';
2498             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2499             SETs(TARG);
2500         }
2501     } else {
2502         if (!SvPADTMP(sv)) {
2503             dTARGET;
2504             sv_setsv(TARG, sv);
2505             sv = TARG;
2506             SETs(sv);
2507         }
2508
2509         s = (U8*)SvPV_force(sv, len);
2510         if (len) {
2511             register U8 *send = s + len;
2512
2513             if (PL_op->op_private & OPpLOCALE) {
2514                 TAINT;
2515                 SvTAINTED_on(sv);
2516                 for (; s < send; s++)
2517                     *s = toLOWER_LC(*s);
2518             }
2519             else {
2520                 for (; s < send; s++)
2521                     *s = toLOWER(*s);
2522             }
2523         }
2524     }
2525     if (SvSMAGICAL(sv))
2526         mg_set(sv);
2527     RETURN;
2528 }
2529
2530 PP(pp_quotemeta)
2531 {
2532     djSP; dTARGET;
2533     SV *sv = TOPs;
2534     STRLEN len;
2535     register char *s = SvPV(sv,len);
2536     register char *d;
2537
2538     if (len) {
2539         (void)SvUPGRADE(TARG, SVt_PV);
2540         SvGROW(TARG, (len * 2) + 1);
2541         d = SvPVX(TARG);
2542         if (IN_UTF8) {
2543             while (len) {
2544                 if (*s & 0x80) {
2545                     STRLEN ulen = UTF8SKIP(s);
2546                     if (ulen > len)
2547                         ulen = len;
2548                     len -= ulen;
2549                     while (ulen--)
2550                         *d++ = *s++;
2551                 }
2552                 else {
2553                     if (!isALNUM(*s))
2554                         *d++ = '\\';
2555                     *d++ = *s++;
2556                     len--;
2557                 }
2558             }
2559         }
2560         else {
2561             while (len--) {
2562                 if (!isALNUM(*s))
2563                     *d++ = '\\';
2564                 *d++ = *s++;
2565             }
2566         }
2567         *d = '\0';
2568         SvCUR_set(TARG, d - SvPVX(TARG));
2569         (void)SvPOK_only(TARG);
2570     }
2571     else
2572         sv_setpvn(TARG, s, len);
2573     SETs(TARG);
2574     if (SvSMAGICAL(TARG))
2575         mg_set(TARG);
2576     RETURN;
2577 }
2578
2579 /* Arrays. */
2580
2581 PP(pp_aslice)
2582 {
2583     djSP; dMARK; dORIGMARK;
2584     register SV** svp;
2585     register AV* av = (AV*)POPs;
2586     register I32 lval = PL_op->op_flags & OPf_MOD;
2587     I32 arybase = PL_curcop->cop_arybase;
2588     I32 elem;
2589
2590     if (SvTYPE(av) == SVt_PVAV) {
2591         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2592             I32 max = -1;
2593             for (svp = MARK + 1; svp <= SP; svp++) {
2594                 elem = SvIVx(*svp);
2595                 if (elem > max)
2596                     max = elem;
2597             }
2598             if (max > AvMAX(av))
2599                 av_extend(av, max);
2600         }
2601         while (++MARK <= SP) {
2602             elem = SvIVx(*MARK);
2603
2604             if (elem > 0)
2605                 elem -= arybase;
2606             svp = av_fetch(av, elem, lval);
2607             if (lval) {
2608                 if (!svp || *svp == &PL_sv_undef)
2609                     DIE(aTHX_ PL_no_aelem, elem);
2610                 if (PL_op->op_private & OPpLVAL_INTRO)
2611                     save_aelem(av, elem, svp);
2612             }
2613             *MARK = svp ? *svp : &PL_sv_undef;
2614         }
2615     }
2616     if (GIMME != G_ARRAY) {
2617         MARK = ORIGMARK;
2618         *++MARK = *SP;
2619         SP = MARK;
2620     }
2621     RETURN;
2622 }
2623
2624 /* Associative arrays. */
2625
2626 PP(pp_each)
2627 {
2628     djSP; dTARGET;
2629     HV *hash = (HV*)POPs;
2630     HE *entry;
2631     I32 gimme = GIMME_V;
2632     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2633
2634     PUTBACK;
2635     /* might clobber stack_sp */
2636     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2637     SPAGAIN;
2638
2639     EXTEND(SP, 2);
2640     if (entry) {
2641         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2642         if (gimme == G_ARRAY) {
2643             PUTBACK;
2644             /* might clobber stack_sp */
2645             sv_setsv(TARG, realhv ?
2646                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2647             SPAGAIN;
2648             PUSHs(TARG);
2649         }
2650     }
2651     else if (gimme == G_SCALAR)
2652         RETPUSHUNDEF;
2653
2654     RETURN;
2655 }
2656
2657 PP(pp_values)
2658 {
2659     return do_kv();
2660 }
2661
2662 PP(pp_keys)
2663 {
2664     return do_kv();
2665 }
2666
2667 PP(pp_delete)
2668 {
2669     djSP;
2670     I32 gimme = GIMME_V;
2671     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2672     SV *sv;
2673     HV *hv;
2674
2675     if (PL_op->op_private & OPpSLICE) {
2676         dMARK; dORIGMARK;
2677         U32 hvtype;
2678         hv = (HV*)POPs;
2679         hvtype = SvTYPE(hv);
2680         while (++MARK <= SP) {
2681             if (hvtype == SVt_PVHV)
2682                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2683             else
2684                 DIE(aTHX_ "Not a HASH reference");
2685             *MARK = sv ? sv : &PL_sv_undef;
2686         }
2687         if (discard)
2688             SP = ORIGMARK;
2689         else if (gimme == G_SCALAR) {
2690             MARK = ORIGMARK;
2691             *++MARK = *SP;
2692             SP = MARK;
2693         }
2694     }
2695     else {
2696         SV *keysv = POPs;
2697         hv = (HV*)POPs;
2698         if (SvTYPE(hv) == SVt_PVHV)
2699             sv = hv_delete_ent(hv, keysv, discard, 0);
2700         else
2701             DIE(aTHX_ "Not a HASH reference");
2702         if (!sv)
2703             sv = &PL_sv_undef;
2704         if (!discard)
2705             PUSHs(sv);
2706     }
2707     RETURN;
2708 }
2709
2710 PP(pp_exists)
2711 {
2712     djSP;
2713     SV *tmpsv = POPs;
2714     HV *hv = (HV*)POPs;
2715     if (SvTYPE(hv) == SVt_PVHV) {
2716         if (hv_exists_ent(hv, tmpsv, 0))
2717             RETPUSHYES;
2718     }
2719     else if (SvTYPE(hv) == SVt_PVAV) {
2720         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2721             RETPUSHYES;
2722     }
2723     else {
2724         DIE(aTHX_ "Not a HASH reference");
2725     }
2726     RETPUSHNO;
2727 }
2728
2729 PP(pp_hslice)
2730 {
2731     djSP; dMARK; dORIGMARK;
2732     register HV *hv = (HV*)POPs;
2733     register I32 lval = PL_op->op_flags & OPf_MOD;
2734     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2735
2736     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2737         DIE(aTHX_ "Can't localize pseudo-hash element");
2738
2739     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2740         while (++MARK <= SP) {
2741             SV *keysv = *MARK;
2742             SV **svp;
2743             if (realhv) {
2744                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2745                 svp = he ? &HeVAL(he) : 0;
2746             }
2747             else {
2748                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2749             }
2750             if (lval) {
2751                 if (!svp || *svp == &PL_sv_undef) {
2752                     STRLEN n_a;
2753                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2754                 }
2755                 if (PL_op->op_private & OPpLVAL_INTRO)
2756                     save_helem(hv, keysv, svp);
2757             }
2758             *MARK = svp ? *svp : &PL_sv_undef;
2759         }
2760     }
2761     if (GIMME != G_ARRAY) {
2762         MARK = ORIGMARK;
2763         *++MARK = *SP;
2764         SP = MARK;
2765     }
2766     RETURN;
2767 }
2768
2769 /* List operators. */
2770
2771 PP(pp_list)
2772 {
2773     djSP; dMARK;
2774     if (GIMME != G_ARRAY) {
2775         if (++MARK <= SP)
2776             *MARK = *SP;                /* unwanted list, return last item */
2777         else
2778             *MARK = &PL_sv_undef;
2779         SP = MARK;
2780     }
2781     RETURN;
2782 }
2783
2784 PP(pp_lslice)
2785 {
2786     djSP;
2787     SV **lastrelem = PL_stack_sp;
2788     SV **lastlelem = PL_stack_base + POPMARK;
2789     SV **firstlelem = PL_stack_base + POPMARK + 1;
2790     register SV **firstrelem = lastlelem + 1;
2791     I32 arybase = PL_curcop->cop_arybase;
2792     I32 lval = PL_op->op_flags & OPf_MOD;
2793     I32 is_something_there = lval;
2794
2795     register I32 max = lastrelem - lastlelem;
2796     register SV **lelem;
2797     register I32 ix;
2798
2799     if (GIMME != G_ARRAY) {
2800         ix = SvIVx(*lastlelem);
2801         if (ix < 0)
2802             ix += max;
2803         else
2804             ix -= arybase;
2805         if (ix < 0 || ix >= max)
2806             *firstlelem = &PL_sv_undef;
2807         else
2808             *firstlelem = firstrelem[ix];
2809         SP = firstlelem;
2810         RETURN;
2811     }
2812
2813     if (max == 0) {
2814         SP = firstlelem - 1;
2815         RETURN;
2816     }
2817
2818     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2819         ix = SvIVx(*lelem);
2820         if (ix < 0)
2821             ix += max;
2822         else
2823             ix -= arybase;
2824         if (ix < 0 || ix >= max)
2825             *lelem = &PL_sv_undef;
2826         else {
2827             is_something_there = TRUE;
2828             if (!(*lelem = firstrelem[ix]))
2829                 *lelem = &PL_sv_undef;
2830         }
2831     }
2832     if (is_something_there)
2833         SP = lastlelem;
2834     else
2835         SP = firstlelem - 1;
2836     RETURN;
2837 }
2838
2839 PP(pp_anonlist)
2840 {
2841     djSP; dMARK; dORIGMARK;
2842     I32 items = SP - MARK;
2843     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2844     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2845     XPUSHs(av);
2846     RETURN;
2847 }
2848
2849 PP(pp_anonhash)
2850 {
2851     djSP; dMARK; dORIGMARK;
2852     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2853
2854     while (MARK < SP) {
2855         SV* key = *++MARK;
2856         SV *val = NEWSV(46, 0);
2857         if (MARK < SP)
2858             sv_setsv(val, *++MARK);
2859         else if (ckWARN(WARN_UNSAFE))
2860             Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2861         (void)hv_store_ent(hv,key,val,0);
2862     }
2863     SP = ORIGMARK;
2864     XPUSHs((SV*)hv);
2865     RETURN;
2866 }
2867
2868 PP(pp_splice)
2869 {
2870     djSP; dMARK; dORIGMARK;
2871     register AV *ary = (AV*)*++MARK;
2872     register SV **src;
2873     register SV **dst;
2874     register I32 i;
2875     register I32 offset;
2876     register I32 length;
2877     I32 newlen;
2878     I32 after;
2879     I32 diff;
2880     SV **tmparyval = 0;
2881     MAGIC *mg;
2882
2883     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2884         *MARK-- = SvTIED_obj((SV*)ary, mg);
2885         PUSHMARK(MARK);
2886         PUTBACK;
2887         ENTER;
2888         call_method("SPLICE",GIMME_V);
2889         LEAVE;
2890         SPAGAIN;
2891         RETURN;
2892     }
2893
2894     SP++;
2895
2896     if (++MARK < SP) {
2897         offset = i = SvIVx(*MARK);
2898         if (offset < 0)
2899             offset += AvFILLp(ary) + 1;
2900         else
2901             offset -= PL_curcop->cop_arybase;
2902         if (offset < 0)
2903             DIE(aTHX_ PL_no_aelem, i);
2904         if (++MARK < SP) {
2905             length = SvIVx(*MARK++);
2906             if (length < 0) {
2907                 length += AvFILLp(ary) - offset + 1;
2908                 if (length < 0)
2909                     length = 0;
2910             }
2911         }
2912         else
2913             length = AvMAX(ary) + 1;            /* close enough to infinity */
2914     }
2915     else {
2916         offset = 0;
2917         length = AvMAX(ary) + 1;
2918     }
2919     if (offset > AvFILLp(ary) + 1)
2920         offset = AvFILLp(ary) + 1;
2921     after = AvFILLp(ary) + 1 - (offset + length);
2922     if (after < 0) {                            /* not that much array */
2923         length += after;                        /* offset+length now in array */
2924         after = 0;
2925         if (!AvALLOC(ary))
2926             av_extend(ary, 0);
2927     }
2928
2929     /* At this point, MARK .. SP-1 is our new LIST */
2930
2931     newlen = SP - MARK;
2932     diff = newlen - length;
2933     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2934         av_reify(ary);
2935
2936     if (diff < 0) {                             /* shrinking the area */
2937         if (newlen) {
2938             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2939             Copy(MARK, tmparyval, newlen, SV*);
2940         }
2941
2942         MARK = ORIGMARK + 1;
2943         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2944             MEXTEND(MARK, length);
2945             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2946             if (AvREAL(ary)) {
2947                 EXTEND_MORTAL(length);
2948                 for (i = length, dst = MARK; i; i--) {
2949                     sv_2mortal(*dst);   /* free them eventualy */
2950                     dst++;
2951                 }
2952             }
2953             MARK += length - 1;
2954         }
2955         else {
2956             *MARK = AvARRAY(ary)[offset+length-1];
2957             if (AvREAL(ary)) {
2958                 sv_2mortal(*MARK);
2959                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2960                     SvREFCNT_dec(*dst++);       /* free them now */
2961             }
2962         }
2963         AvFILLp(ary) += diff;
2964
2965         /* pull up or down? */
2966
2967         if (offset < after) {                   /* easier to pull up */
2968             if (offset) {                       /* esp. if nothing to pull */
2969                 src = &AvARRAY(ary)[offset-1];
2970                 dst = src - diff;               /* diff is negative */
2971                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2972                     *dst-- = *src--;
2973             }
2974             dst = AvARRAY(ary);
2975             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2976             AvMAX(ary) += diff;
2977         }
2978         else {
2979             if (after) {                        /* anything to pull down? */
2980                 src = AvARRAY(ary) + offset + length;
2981                 dst = src + diff;               /* diff is negative */
2982                 Move(src, dst, after, SV*);
2983             }
2984             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2985                                                 /* avoid later double free */
2986         }
2987         i = -diff;
2988         while (i)
2989             dst[--i] = &PL_sv_undef;
2990
2991         if (newlen) {
2992             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2993               newlen; newlen--) {
2994                 *dst = NEWSV(46, 0);
2995                 sv_setsv(*dst++, *src++);
2996             }
2997             Safefree(tmparyval);
2998         }
2999     }
3000     else {                                      /* no, expanding (or same) */
3001         if (length) {
3002             New(452, tmparyval, length, SV*);   /* so remember deletion */
3003             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3004         }
3005
3006         if (diff > 0) {                         /* expanding */
3007
3008             /* push up or down? */
3009
3010             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3011                 if (offset) {
3012                     src = AvARRAY(ary);
3013                     dst = src - diff;
3014                     Move(src, dst, offset, SV*);
3015                 }
3016                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3017                 AvMAX(ary) += diff;
3018                 AvFILLp(ary) += diff;
3019             }
3020             else {
3021                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3022                     av_extend(ary, AvFILLp(ary) + diff);
3023                 AvFILLp(ary) += diff;
3024
3025                 if (after) {
3026                     dst = AvARRAY(ary) + AvFILLp(ary);
3027                     src = dst - diff;
3028                     for (i = after; i; i--) {
3029                         *dst-- = *src--;
3030                     }
3031                 }
3032             }
3033         }
3034
3035         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3036             *dst = NEWSV(46, 0);
3037             sv_setsv(*dst++, *src++);
3038         }
3039         MARK = ORIGMARK + 1;
3040         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3041             if (length) {
3042                 Copy(tmparyval, MARK, length, SV*);
3043                 if (AvREAL(ary)) {
3044                     EXTEND_MORTAL(length);
3045                     for (i = length, dst = MARK; i; i--) {
3046                         sv_2mortal(*dst);       /* free them eventualy */
3047                         dst++;
3048                     }
3049                 }
3050                 Safefree(tmparyval);
3051             }
3052             MARK += length - 1;
3053         }
3054         else if (length--) {
3055             *MARK = tmparyval[length];
3056             if (AvREAL(ary)) {
3057                 sv_2mortal(*MARK);
3058                 while (length-- > 0)
3059                     SvREFCNT_dec(tmparyval[length]);
3060             }
3061             Safefree(tmparyval);
3062         }
3063         else
3064             *MARK = &PL_sv_undef;
3065     }
3066     SP = MARK;
3067     RETURN;
3068 }
3069
3070 PP(pp_push)
3071 {
3072     djSP; dMARK; dORIGMARK; dTARGET;
3073     register AV *ary = (AV*)*++MARK;
3074     register SV *sv = &PL_sv_undef;
3075     MAGIC *mg;
3076
3077     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3078         *MARK-- = SvTIED_obj((SV*)ary, mg);
3079         PUSHMARK(MARK);
3080         PUTBACK;
3081         ENTER;
3082         call_method("PUSH",G_SCALAR|G_DISCARD);
3083         LEAVE;
3084         SPAGAIN;
3085     }
3086     else {
3087         /* Why no pre-extend of ary here ? */
3088         for (++MARK; MARK <= SP; MARK++) {
3089             sv = NEWSV(51, 0);
3090             if (*MARK)
3091                 sv_setsv(sv, *MARK);
3092             av_push(ary, sv);
3093         }
3094     }
3095     SP = ORIGMARK;
3096     PUSHi( AvFILL(ary) + 1 );
3097     RETURN;
3098 }
3099
3100 PP(pp_pop)
3101 {
3102     djSP;
3103     AV *av = (AV*)POPs;
3104     SV *sv = av_pop(av);
3105     if (AvREAL(av))
3106         (void)sv_2mortal(sv);
3107     PUSHs(sv);
3108     RETURN;
3109 }
3110
3111 PP(pp_shift)
3112 {
3113     djSP;
3114     AV *av = (AV*)POPs;
3115     SV *sv = av_shift(av);
3116     EXTEND(SP, 1);
3117     if (!sv)
3118         RETPUSHUNDEF;
3119     if (AvREAL(av))
3120         (void)sv_2mortal(sv);
3121     PUSHs(sv);
3122     RETURN;
3123 }
3124
3125 PP(pp_unshift)
3126 {
3127     djSP; dMARK; dORIGMARK; dTARGET;
3128     register AV *ary = (AV*)*++MARK;
3129     register SV *sv;
3130     register I32 i = 0;
3131     MAGIC *mg;
3132
3133     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3134         *MARK-- = SvTIED_obj((SV*)ary, mg);
3135         PUSHMARK(MARK);
3136         PUTBACK;
3137         ENTER;
3138         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3139         LEAVE;
3140         SPAGAIN;
3141     }
3142     else {
3143         av_unshift(ary, SP - MARK);
3144         while (MARK < SP) {
3145             sv = NEWSV(27, 0);
3146             sv_setsv(sv, *++MARK);
3147             (void)av_store(ary, i++, sv);
3148         }
3149     }
3150     SP = ORIGMARK;
3151     PUSHi( AvFILL(ary) + 1 );
3152     RETURN;
3153 }
3154
3155 PP(pp_reverse)
3156 {
3157     djSP; dMARK;
3158     register SV *tmp;
3159     SV **oldsp = SP;
3160
3161     if (GIMME == G_ARRAY) {
3162         MARK++;
3163         while (MARK < SP) {
3164             tmp = *MARK;
3165             *MARK++ = *SP;
3166             *SP-- = tmp;
3167         }
3168         SP = oldsp;
3169     }
3170     else {
3171         register char *up;
3172         register char *down;
3173         register I32 tmp;
3174         dTARGET;
3175         STRLEN len;
3176
3177         if (SP - MARK > 1)
3178             do_join(TARG, &PL_sv_no, MARK, SP);
3179         else
3180             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3181         up = SvPV_force(TARG, len);
3182         if (len > 1) {
3183             if (IN_UTF8) {      /* first reverse each character */
3184                 U8* s = (U8*)SvPVX(TARG);
3185                 U8* send = (U8*)(s + len);
3186                 while (s < send) {
3187                     if (*s < 0x80) {
3188                         s++;
3189                         continue;
3190                     }
3191                     else {
3192                         up = (char*)s;
3193                         s += UTF8SKIP(s);
3194                         down = (char*)(s - 1);
3195                         if (s > send || !((*down & 0xc0) == 0x80)) {
3196                             if (ckWARN_d(WARN_UTF8))
3197                                 Perl_warner(aTHX_ WARN_UTF8,
3198                                             "Malformed UTF-8 character");
3199                             break;
3200                         }
3201                         while (down > up) {
3202                             tmp = *up;
3203                             *up++ = *down;
3204                             *down-- = tmp;
3205                         }
3206                     }
3207                 }
3208                 up = SvPVX(TARG);
3209             }
3210             down = SvPVX(TARG) + len - 1;
3211             while (down > up) {
3212                 tmp = *up;
3213                 *up++ = *down;
3214                 *down-- = tmp;
3215             }
3216             (void)SvPOK_only(TARG);
3217         }
3218         SP = MARK + 1;
3219         SETTARG;
3220     }
3221     RETURN;
3222 }
3223
3224 STATIC SV *
3225 S_mul128(pTHX_ SV *sv, U8 m)
3226 {
3227   STRLEN          len;
3228   char           *s = SvPV(sv, len);
3229   char           *t;
3230   U32             i = 0;
3231
3232   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3233     SV             *tmpNew = newSVpvn("0000000000", 10);
3234
3235     sv_catsv(tmpNew, sv);
3236     SvREFCNT_dec(sv);           /* free old sv */
3237     sv = tmpNew;
3238     s = SvPV(sv, len);
3239   }
3240   t = s + len - 1;
3241   while (!*t)                   /* trailing '\0'? */
3242     t--;
3243   while (t > s) {
3244     i = ((*t - '0') << 7) + m;
3245     *(t--) = '0' + (i % 10);
3246     m = i / 10;
3247   }
3248   return (sv);
3249 }
3250
3251 /* Explosives and implosives. */
3252
3253 #if 'I' == 73 && 'J' == 74
3254 /* On an ASCII/ISO kind of system */
3255 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3256 #else
3257 /*
3258   Some other sort of character set - use memchr() so we don't match
3259   the null byte.
3260  */
3261 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3262 #endif
3263
3264 PP(pp_unpack)
3265 {
3266     djSP;
3267     dPOPPOPssrl;
3268     SV **oldsp = SP;
3269     I32 gimme = GIMME_V;
3270     SV *sv;
3271     STRLEN llen;
3272     STRLEN rlen;
3273     register char *pat = SvPV(left, llen);
3274     register char *s = SvPV(right, rlen);
3275     char *strend = s + rlen;
3276     char *strbeg = s;
3277     register char *patend = pat + llen;
3278     I32 datumtype;
3279     register I32 len;
3280     register I32 bits;
3281
3282     /* These must not be in registers: */
3283     I16 ashort;
3284     int aint;
3285     I32 along;
3286 #ifdef HAS_QUAD
3287     Quad_t aquad;
3288 #endif
3289     U16 aushort;
3290     unsigned int auint;
3291     U32 aulong;
3292 #ifdef HAS_QUAD
3293     Uquad_t auquad;
3294 #endif
3295     char *aptr;
3296     float afloat;
3297     double adouble;
3298     I32 checksum = 0;
3299     register U32 culong;
3300     NV cdouble;
3301     int commas = 0;
3302 #ifdef PERL_NATINT_PACK
3303     int natint;         /* native integer */
3304     int unatint;        /* unsigned native integer */
3305 #endif
3306
3307     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3308         /*SUPPRESS 530*/
3309         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3310         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3311             patend++;
3312             while (isDIGIT(*patend) || *patend == '*')
3313                 patend++;
3314         }
3315         else
3316             patend++;
3317     }
3318     while (pat < patend) {
3319       reparse:
3320         datumtype = *pat++ & 0xFF;
3321 #ifdef PERL_NATINT_PACK
3322         natint = 0;
3323 #endif
3324         if (isSPACE(datumtype))
3325             continue;
3326         if (*pat == '!') {
3327             char *natstr = "sSiIlL";
3328
3329             if (strchr(natstr, datumtype)) {
3330 #ifdef PERL_NATINT_PACK
3331                 natint = 1;
3332 #endif
3333                 pat++;
3334             }
3335             else
3336                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3337         }
3338         if (pat >= patend)
3339             len = 1;
3340         else if (*pat == '*') {
3341             len = strend - strbeg;      /* long enough */
3342             pat++;
3343         }
3344         else if (isDIGIT(*pat)) {
3345             len = *pat++ - '0';
3346             while (isDIGIT(*pat))
3347                 len = (len * 10) + (*pat++ - '0');
3348         }
3349         else
3350             len = (datumtype != '@');
3351         switch(datumtype) {
3352         default:
3353             Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3354         case ',': /* grandfather in commas but with a warning */
3355             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3356                 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3357             break;
3358         case '%':
3359             if (len == 1 && pat[-1] != '1')
3360                 len = 16;
3361             checksum = len;
3362             culong = 0;
3363             cdouble = 0;
3364             if (pat < patend)
3365                 goto reparse;
3366             break;
3367         case '@':
3368             if (len > strend - strbeg)
3369                 DIE(aTHX_ "@ outside of string");
3370             s = strbeg + len;
3371             break;
3372         case 'X':
3373             if (len > s - strbeg)
3374                 DIE(aTHX_ "X outside of string");
3375             s -= len;
3376             break;
3377         case 'x':
3378             if (len > strend - s)
3379                 DIE(aTHX_ "x outside of string");
3380             s += len;
3381             break;
3382         case 'A':
3383         case 'Z':
3384         case 'a':
3385             if (len > strend - s)
3386                 len = strend - s;
3387             if (checksum)
3388                 goto uchar_checksum;
3389             sv = NEWSV(35, len);
3390             sv_setpvn(sv, s, len);
3391             s += len;
3392             if (datumtype == 'A' || datumtype == 'Z') {
3393                 aptr = s;       /* borrow register */
3394                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3395                     s = SvPVX(sv);
3396                     while (*s)
3397                         s++;
3398                 }
3399                 else {          /* 'A' strips both nulls and spaces */
3400                     s = SvPVX(sv) + len - 1;
3401                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3402                         s--;
3403                     *++s = '\0';
3404                 }
3405                 SvCUR_set(sv, s - SvPVX(sv));
3406                 s = aptr;       /* unborrow register */
3407             }
3408             XPUSHs(sv_2mortal(sv));
3409             break;
3410         case 'B':
3411         case 'b':
3412             if (pat[-1] == '*' || len > (strend - s) * 8)
3413                 len = (strend - s) * 8;
3414             if (checksum) {
3415                 if (!PL_bitcount) {
3416                     Newz(601, PL_bitcount, 256, char);
3417                     for (bits = 1; bits < 256; bits++) {
3418                         if (bits & 1)   PL_bitcount[bits]++;
3419                         if (bits & 2)   PL_bitcount[bits]++;
3420                         if (bits & 4)   PL_bitcount[bits]++;
3421                         if (bits & 8)   PL_bitcount[bits]++;
3422                         if (bits & 16)  PL_bitcount[bits]++;
3423                         if (bits & 32)  PL_bitcount[bits]++;
3424                         if (bits & 64)  PL_bitcount[bits]++;
3425                         if (bits & 128) PL_bitcount[bits]++;
3426                     }
3427                 }
3428                 while (len >= 8) {
3429                     culong += PL_bitcount[*(unsigned char*)s++];
3430                     len -= 8;
3431                 }
3432                 if (len) {
3433                     bits = *s;
3434                     if (datumtype == 'b') {
3435                         while (len-- > 0) {
3436                             if (bits & 1) culong++;
3437                             bits >>= 1;
3438                         }
3439                     }
3440                     else {
3441                         while (len-- > 0) {
3442                             if (bits & 128) culong++;
3443                             bits <<= 1;
3444                         }
3445                     }
3446                 }
3447                 break;
3448             }
3449             sv = NEWSV(35, len + 1);
3450             SvCUR_set(sv, len);
3451             SvPOK_on(sv);
3452             aptr = pat;                 /* borrow register */
3453             pat = SvPVX(sv);
3454             if (datumtype == 'b') {
3455                 aint = len;
3456                 for (len = 0; len < aint; len++) {
3457                     if (len & 7)                /*SUPPRESS 595*/
3458                         bits >>= 1;
3459                     else
3460                         bits = *s++;
3461                     *pat++ = '0' + (bits & 1);
3462                 }
3463             }
3464             else {
3465                 aint = len;
3466                 for (len = 0; len < aint; len++) {
3467                     if (len & 7)
3468                         bits <<= 1;
3469                     else
3470                         bits = *s++;
3471                     *pat++ = '0' + ((bits & 128) != 0);
3472                 }
3473             }
3474             *pat = '\0';
3475             pat = aptr;                 /* unborrow register */
3476             XPUSHs(sv_2mortal(sv));
3477             break;
3478         case 'H':
3479         case 'h':
3480             if (pat[-1] == '*' || len > (strend - s) * 2)
3481                 len = (strend - s) * 2;
3482             sv = NEWSV(35, len + 1);
3483             SvCUR_set(sv, len);
3484             SvPOK_on(sv);
3485             aptr = pat;                 /* borrow register */
3486             pat = SvPVX(sv);
3487             if (datumtype == 'h') {
3488                 aint = len;
3489                 for (len = 0; len < aint; len++) {
3490                     if (len & 1)
3491                         bits >>= 4;
3492                     else
3493                         bits = *s++;
3494                     *pat++ = PL_hexdigit[bits & 15];
3495                 }
3496             }
3497             else {
3498                 aint = len;
3499                 for (len = 0; len < aint; len++) {
3500                     if (len & 1)
3501                         bits <<= 4;
3502                     else
3503                         bits = *s++;
3504                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3505                 }
3506             }
3507             *pat = '\0';
3508             pat = aptr;                 /* unborrow register */
3509             XPUSHs(sv_2mortal(sv));
3510             break;
3511         case 'c':
3512             if (len > strend - s)
3513                 len = strend - s;
3514             if (checksum) {
3515                 while (len-- > 0) {
3516                     aint = *s++;
3517                     if (aint >= 128)    /* fake up signed chars */
3518                         aint -= 256;
3519                     culong += aint;
3520                 }
3521             }
3522             else {
3523                 EXTEND(SP, len);
3524                 EXTEND_MORTAL(len);
3525                 while (len-- > 0) {
3526                     aint = *s++;
3527                     if (aint >= 128)    /* fake up signed chars */
3528                         aint -= 256;
3529                     sv = NEWSV(36, 0);
3530                     sv_setiv(sv, (IV)aint);
3531                     PUSHs(sv_2mortal(sv));
3532                 }
3533             }
3534             break;
3535         case 'C':
3536             if (len > strend - s)
3537                 len = strend - s;
3538             if (checksum) {
3539               uchar_checksum:
3540                 while (len-- > 0) {
3541                     auint = *s++ & 255;
3542                     culong += auint;
3543                 }
3544             }
3545             else {
3546                 EXTEND(SP, len);
3547                 EXTEND_MORTAL(len);
3548                 while (len-- > 0) {
3549                     auint = *s++ & 255;
3550                     sv = NEWSV(37, 0);
3551                     sv_setiv(sv, (IV)auint);
3552                     PUSHs(sv_2mortal(sv));
3553                 }
3554             }
3555             break;
3556         case 'U':
3557             if (len > strend - s)
3558                 len = strend - s;
3559             if (checksum) {
3560                 while (len-- > 0 && s < strend) {
3561                     auint = utf8_to_uv((U8*)s, &along);
3562                     s += along;
3563                     if (checksum > 32)
3564                         cdouble += (NV)auint;
3565                     else
3566                         culong += auint;
3567                 }
3568             }
3569             else {
3570                 EXTEND(SP, len);
3571                 EXTEND_MORTAL(len);
3572                 while (len-- > 0 && s < strend) {
3573                     auint = utf8_to_uv((U8*)s, &along);
3574                     s += along;
3575                     sv = NEWSV(37, 0);
3576                     sv_setuv(sv, (UV)auint);
3577                     PUSHs(sv_2mortal(sv));
3578                 }
3579             }
3580             break;
3581         case 's':
3582 #if SHORTSIZE == SIZE16
3583             along = (strend - s) / SIZE16;
3584 #else
3585             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3586 #endif
3587             if (len > along)
3588                 len = along;
3589             if (checksum) {
3590 #if SHORTSIZE != SIZE16
3591                 if (natint) {
3592                     while (len-- > 0) {
3593                         COPYNN(s, &ashort, sizeof(short));
3594                         s += sizeof(short);
3595                         culong += ashort;
3596
3597                     }
3598                 }
3599                 else
3600 #endif
3601                 {
3602                     while (len-- > 0) {
3603                         COPY16(s, &ashort);
3604 #if SHORTSIZE > SIZE16
3605                         if (ashort > 32767)
3606                           ashort -= 65536;
3607 #endif
3608                         s += SIZE16;
3609                         culong += ashort;
3610                     }
3611                 }
3612             }
3613             else {
3614                 EXTEND(SP, len);
3615                 EXTEND_MORTAL(len);
3616 #if SHORTSIZE != SIZE16
3617                 if (natint) {
3618                     while (len-- > 0) {
3619                         COPYNN(s, &ashort, sizeof(short));
3620                         s += sizeof(short);
3621                         sv = NEWSV(38, 0);
3622                         sv_setiv(sv, (IV)ashort);
3623                         PUSHs(sv_2mortal(sv));
3624                     }
3625                 }
3626                 else
3627 #endif
3628                 {
3629                     while (len-- > 0) {
3630                         COPY16(s, &ashort);
3631 #if SHORTSIZE > SIZE16
3632                         if (ashort > 32767)
3633                           ashort -= 65536;
3634 #endif
3635                         s += SIZE16;
3636                         sv = NEWSV(38, 0);
3637                         sv_setiv(sv, (IV)ashort);
3638                         PUSHs(sv_2mortal(sv));
3639                     }
3640                 }
3641             }
3642             break;
3643         case 'v':
3644         case 'n':
3645         case 'S':
3646 #if SHORTSIZE == SIZE16
3647             along = (strend - s) / SIZE16;
3648 #else
3649             unatint = natint && datumtype == 'S';
3650             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3651 #endif
3652             if (len > along)
3653                 len = along;
3654             if (checksum) {
3655 #if SHORTSIZE != SIZE16
3656                 if (unatint) {
3657                     while (len-- > 0) {
3658                         COPYNN(s, &aushort, sizeof(unsigned short));
3659                         s += sizeof(unsigned short);
3660                         culong += aushort;
3661                     }
3662                 }
3663                 else
3664 #endif
3665                 {
3666                     while (len-- > 0) {
3667                         COPY16(s, &aushort);
3668                         s += SIZE16;
3669 #ifdef HAS_NTOHS
3670                         if (datumtype == 'n')
3671                             aushort = PerlSock_ntohs(aushort);
3672 #endif
3673 #ifdef HAS_VTOHS
3674                         if (datumtype == 'v')
3675                             aushort = vtohs(aushort);
3676 #endif
3677                         culong += aushort;
3678                     }
3679                 }
3680             }
3681             else {
3682                 EXTEND(SP, len);
3683                 EXTEND_MORTAL(len);
3684 #if SHORTSIZE != SIZE16
3685                 if (unatint) {
3686                     while (len-- > 0) {
3687                         COPYNN(s, &aushort, sizeof(unsigned short));
3688                         s += sizeof(unsigned short);
3689                         sv = NEWSV(39, 0);
3690                         sv_setiv(sv, (UV)aushort);
3691                         PUSHs(sv_2mortal(sv));
3692                     }
3693                 }
3694                 else
3695 #endif
3696                 {
3697                     while (len-- > 0) {
3698                         COPY16(s, &aushort);
3699                         s += SIZE16;
3700                         sv = NEWSV(39, 0);
3701 #ifdef HAS_NTOHS
3702                         if (datumtype == 'n')
3703                             aushort = PerlSock_ntohs(aushort);
3704 #endif
3705 #ifdef HAS_VTOHS
3706                         if (datumtype == 'v')
3707                             aushort = vtohs(aushort);
3708 #endif
3709                         sv_setiv(sv, (UV)aushort);
3710                         PUSHs(sv_2mortal(sv));
3711                     }
3712                 }
3713             }
3714             break;
3715         case 'i':
3716             along = (strend - s) / sizeof(int);
3717             if (len > along)
3718                 len = along;
3719             if (checksum) {
3720                 while (len-- > 0) {
3721                     Copy(s, &aint, 1, int);
3722                     s += sizeof(int);
3723                     if (checksum > 32)
3724                         cdouble += (NV)aint;
3725                     else
3726                         culong += aint;
3727                 }
3728             }
3729             else {
3730                 EXTEND(SP, len);
3731                 EXTEND_MORTAL(len);
3732                 while (len-- > 0) {
3733                     Copy(s, &aint, 1, int);
3734                     s += sizeof(int);
3735                     sv = NEWSV(40, 0);
3736 #ifdef __osf__
3737                     /* Without the dummy below unpack("i", pack("i",-1))
3738                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3739                      * cc with optimization turned on.
3740                      *
3741                      * The bug was detected in
3742                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3743                      * with optimization (-O4) turned on.
3744                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3745                      * does not have this problem even with -O4.
3746                      *
3747                      * This bug was reported as DECC_BUGS 1431
3748                      * and tracked internally as GEM_BUGS 7775.
3749                      *
3750                      * The bug is fixed in
3751                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3752                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3753                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3754                      * and also in DTK.
3755                      *
3756                      * See also few lines later for the same bug.
3757                      */
3758                     (aint) ?
3759                         sv_setiv(sv, (IV)aint) :
3760 #endif
3761                     sv_setiv(sv, (IV)aint);
3762                     PUSHs(sv_2mortal(sv));
3763                 }
3764             }
3765             break;
3766         case 'I':
3767             along = (strend - s) / sizeof(unsigned int);
3768             if (len > along)
3769                 len = along;
3770             if (checksum) {
3771                 while (len-- > 0) {
3772                     Copy(s, &auint, 1, unsigned int);
3773                     s += sizeof(unsigned int);
3774                     if (checksum > 32)
3775                         cdouble += (NV)auint;
3776                     else
3777                         culong += auint;
3778                 }
3779             }
3780             else {
3781                 EXTEND(SP, len);
3782                 EXTEND_MORTAL(len);
3783                 while (len-- > 0) {
3784                     Copy(s, &auint, 1, unsigned int);
3785                     s += sizeof(unsigned int);
3786                     sv = NEWSV(41, 0);
3787 #ifdef __osf__
3788                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3789                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3790                      * See details few lines earlier. */
3791                     (auint) ?
3792                         sv_setuv(sv, (UV)auint) :
3793 #endif
3794                     sv_setuv(sv, (UV)auint);
3795                     PUSHs(sv_2mortal(sv));
3796                 }
3797             }
3798             break;
3799         case 'l':
3800 #if LONGSIZE == SIZE32
3801             along = (strend - s) / SIZE32;
3802 #else
3803             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3804 #endif
3805             if (len > along)
3806                 len = along;
3807             if (checksum) {
3808 #if LONGSIZE != SIZE32
3809                 if (natint) {
3810                     while (len-- > 0) {
3811                         COPYNN(s, &along, sizeof(long));
3812                         s += sizeof(long);
3813                         if (checksum > 32)
3814                             cdouble += (NV)along;
3815                         else
3816                             culong += along;
3817                     }
3818                 }
3819                 else
3820 #endif
3821                 {
3822                     while (len-- > 0) {
3823                         COPY32(s, &along);
3824 #if LONGSIZE > SIZE32
3825                         if (along > 2147483647)
3826                           along -= 4294967296;
3827 #endif
3828                         s += SIZE32;
3829                         if (checksum > 32)
3830                             cdouble += (NV)along;
3831                         else
3832                             culong += along;
3833                     }
3834                 }
3835             }
3836             else {
3837                 EXTEND(SP, len);
3838                 EXTEND_MORTAL(len);
3839 #if LONGSIZE != SIZE32
3840                 if (natint) {
3841                     while (len-- > 0) {
3842                         COPYNN(s, &along, sizeof(long));
3843                         s += sizeof(long);
3844                         sv = NEWSV(42, 0);
3845                         sv_setiv(sv, (IV)along);
3846                         PUSHs(sv_2mortal(sv));
3847                     }
3848                 }
3849                 else
3850 #endif
3851                 {
3852                     while (len-- > 0) {
3853                         COPY32(s, &along);
3854 #if LONGSIZE > SIZE32
3855                         if (along > 2147483647)
3856                           along -= 4294967296;
3857 #endif
3858                         s += SIZE32;
3859                         sv = NEWSV(42, 0);
3860                         sv_setiv(sv, (IV)along);
3861                         PUSHs(sv_2mortal(sv));
3862                     }
3863                 }
3864             }
3865             break;
3866         case 'V':
3867         case 'N':
3868         case 'L':
3869 #if LONGSIZE == SIZE32
3870             along = (strend - s) / SIZE32;
3871 #else
3872             unatint = natint && datumtype == 'L';
3873             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3874 #endif
3875             if (len > along)
3876                 len = along;
3877             if (checksum) {
3878 #if LONGSIZE != SIZE32
3879                 if (unatint) {
3880                     while (len-- > 0) {
3881                         COPYNN(s, &aulong, sizeof(unsigned long));
3882                         s += sizeof(unsigned long);
3883                         if (checksum > 32)
3884                             cdouble += (NV)aulong;
3885                         else
3886                             culong += aulong;
3887                     }
3888                 }
3889                 else
3890 #endif
3891                 {
3892                     while (len-- > 0) {
3893                         COPY32(s, &aulong);
3894                         s += SIZE32;
3895 #ifdef HAS_NTOHL
3896                         if (datumtype == 'N')
3897                             aulong = PerlSock_ntohl(aulong);
3898 #endif
3899 #ifdef HAS_VTOHL
3900                         if (datumtype == 'V')
3901                             aulong = vtohl(aulong);
3902 #endif
3903                         if (checksum > 32)
3904                             cdouble += (NV)aulong;
3905                         else
3906                             culong += aulong;
3907                     }
3908                 }
3909             }
3910             else {
3911                 EXTEND(SP, len);
3912                 EXTEND_MORTAL(len);
3913 #if LONGSIZE != SIZE32
3914                 if (unatint) {
3915                     while (len-- > 0) {
3916                         COPYNN(s, &aulong, sizeof(unsigned long));
3917                         s += sizeof(unsigned long);
3918                         sv = NEWSV(43, 0);
3919                         sv_setuv(sv, (UV)aulong);
3920                         PUSHs(sv_2mortal(sv));
3921                     }
3922                 }
3923                 else
3924 #endif
3925                 {
3926                     while (len-- > 0) {
3927                         COPY32(s, &aulong);
3928                         s += SIZE32;
3929 #ifdef HAS_NTOHL
3930                         if (datumtype == 'N')
3931                             aulong = PerlSock_ntohl(aulong);
3932 #endif
3933 #ifdef HAS_VTOHL
3934                         if (datumtype == 'V')
3935                             aulong = vtohl(aulong);
3936 #endif
3937                         sv = NEWSV(43, 0);
3938                         sv_setuv(sv, (UV)aulong);
3939                         PUSHs(sv_2mortal(sv));
3940                     }
3941                 }
3942             }
3943             break;
3944         case 'p':
3945             along = (strend - s) / sizeof(char*);
3946             if (len > along)
3947                 len = along;
3948             EXTEND(SP, len);
3949             EXTEND_MORTAL(len);
3950             while (len-- > 0) {
3951                 if (sizeof(char*) > strend - s)
3952                     break;
3953                 else {
3954                     Copy(s, &aptr, 1, char*);
3955                     s += sizeof(char*);
3956                 }
3957                 sv = NEWSV(44, 0);
3958                 if (aptr)
3959                     sv_setpv(sv, aptr);
3960                 PUSHs(sv_2mortal(sv));
3961             }
3962             break;
3963         case 'w':
3964             EXTEND(SP, len);
3965             EXTEND_MORTAL(len);
3966             {
3967                 UV auv = 0;
3968                 U32 bytes = 0;
3969
3970                 while ((len > 0) && (s < strend)) {
3971                     auv = (auv << 7) | (*s & 0x7f);
3972                     if (!(*s++ & 0x80)) {
3973                         bytes = 0;
3974                         sv = NEWSV(40, 0);
3975                         sv_setuv(sv, auv);
3976                         PUSHs(sv_2mortal(sv));
3977                         len--;
3978                         auv = 0;
3979                     }
3980                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3981                         char *t;
3982                         STRLEN n_a;
3983
3984                         sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3985                         while (s < strend) {
3986                             sv = mul128(sv, *s & 0x7f);
3987                             if (!(*s++ & 0x80)) {
3988                                 bytes = 0;
3989                                 break;
3990                             }
3991                         }
3992                         t = SvPV(sv, n_a);
3993                         while (*t == '0')
3994                             t++;
3995                         sv_chop(sv, t);
3996                         PUSHs(sv_2mortal(sv));
3997                         len--;
3998                         auv = 0;
3999                     }
4000                 }
4001                 if ((s >= strend) && bytes)
4002                     Perl_croak(aTHX_ "Unterminated compressed integer");
4003             }
4004             break;
4005         case 'P':
4006             EXTEND(SP, 1);
4007             if (sizeof(char*) > strend - s)
4008                 break;
4009             else {
4010                 Copy(s, &aptr, 1, char*);
4011                 s += sizeof(char*);
4012             }
4013             sv = NEWSV(44, 0);
4014             if (aptr)
4015                 sv_setpvn(sv, aptr, len);
4016             PUSHs(sv_2mortal(sv));
4017             break;
4018 #ifdef HAS_QUAD
4019         case 'q':
4020             along = (strend - s) / sizeof(Quad_t);
4021             if (len > along)
4022                 len = along;
4023             EXTEND(SP, len);
4024             EXTEND_MORTAL(len);
4025             while (len-- > 0) {
4026                 if (s + sizeof(Quad_t) > strend)
4027                     aquad = 0;
4028                 else {
4029                     Copy(s, &aquad, 1, Quad_t);
4030                     s += sizeof(Quad_t);
4031                 }
4032                 sv = NEWSV(42, 0);
4033                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4034                     sv_setiv(sv, (IV)aquad);
4035                 else
4036                     sv_setnv(sv, (NV)aquad);
4037                 PUSHs(sv_2mortal(sv));
4038             }
4039             break;
4040         case 'Q':
4041             along = (strend - s) / sizeof(Quad_t);
4042             if (len > along)
4043                 len = along;
4044             EXTEND(SP, len);
4045             EXTEND_MORTAL(len);
4046             while (len-- > 0) {
4047                 if (s + sizeof(Uquad_t) > strend)
4048                     auquad = 0;
4049                 else {
4050                     Copy(s, &auquad, 1, Uquad_t);
4051                     s += sizeof(Uquad_t);
4052                 }
4053                 sv = NEWSV(43, 0);
4054                 if (auquad <= UV_MAX)
4055                     sv_setuv(sv, (UV)auquad);
4056                 else
4057                     sv_setnv(sv, (NV)auquad);
4058                 PUSHs(sv_2mortal(sv));
4059             }
4060             break;
4061 #endif
4062         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4063         case 'f':
4064         case 'F':
4065             along = (strend - s) / sizeof(float);
4066             if (len > along)
4067                 len = along;
4068             if (checksum) {
4069                 while (len-- > 0) {
4070                     Copy(s, &afloat, 1, float);
4071                     s += sizeof(float);
4072                     cdouble += afloat;
4073                 }
4074             }
4075             else {
4076                 EXTEND(SP, len);
4077                 EXTEND_MORTAL(len);
4078                 while (len-- > 0) {
4079                     Copy(s, &afloat, 1, float);
4080                     s += sizeof(float);
4081                     sv = NEWSV(47, 0);
4082                     sv_setnv(sv, (NV)afloat);
4083                     PUSHs(sv_2mortal(sv));
4084                 }
4085             }
4086             break;
4087         case 'd':
4088         case 'D':
4089             along = (strend - s) / sizeof(double);
4090             if (len > along)
4091                 len = along;
4092             if (checksum) {
4093                 while (len-- > 0) {
4094                     Copy(s, &adouble, 1, double);
4095                     s += sizeof(double);
4096                     cdouble += adouble;
4097                 }
4098             }
4099             else {
4100                 EXTEND(SP, len);
4101                 EXTEND_MORTAL(len);
4102                 while (len-- > 0) {
4103                     Copy(s, &adouble, 1, double);
4104                     s += sizeof(double);
4105                     sv = NEWSV(48, 0);
4106                     sv_setnv(sv, (NV)adouble);
4107                     PUSHs(sv_2mortal(sv));
4108                 }
4109             }
4110             break;
4111         case 'u':
4112             /* MKS:
4113              * Initialise the decode mapping.  By using a table driven
4114              * algorithm, the code will be character-set independent
4115              * (and just as fast as doing character arithmetic)
4116              */
4117             if (PL_uudmap['M'] == 0) {
4118                 int i;
4119
4120                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4121                     PL_uudmap[PL_uuemap[i]] = i;
4122                 /*
4123                  * Because ' ' and '`' map to the same value,
4124                  * we need to decode them both the same.
4125                  */
4126                 PL_uudmap[' '] = 0;
4127             }
4128
4129             along = (strend - s) * 3 / 4;
4130             sv = NEWSV(42, along);
4131             if (along)
4132                 SvPOK_on(sv);
4133             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4134                 I32 a, b, c, d;
4135                 char hunk[4];
4136
4137                 hunk[3] = '\0';
4138                 len = PL_uudmap[*s++] & 077;
4139                 while (len > 0) {
4140                     if (s < strend && ISUUCHAR(*s))
4141                         a = PL_uudmap[*s++] & 077;
4142                     else
4143                         a = 0;
4144                     if (s < strend && ISUUCHAR(*s))
4145                         b = PL_uudmap[*s++] & 077;
4146                     else
4147                         b = 0;
4148                     if (s < strend && ISUUCHAR(*s))
4149                         c = PL_uudmap[*s++] & 077;
4150                     else
4151                         c = 0;
4152                     if (s < strend && ISUUCHAR(*s))
4153                         d = PL_uudmap[*s++] & 077;
4154                     else
4155                         d = 0;
4156                     hunk[0] = (a << 2) | (b >> 4);
4157                     hunk[1] = (b << 4) | (c >> 2);
4158                     hunk[2] = (c << 6) | d;
4159                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4160                     len -= 3;
4161                 }
4162                 if (*s == '\n')
4163                     s++;
4164                 else if (s[1] == '\n')          /* possible checksum byte */
4165                     s += 2;
4166             }
4167             XPUSHs(sv_2mortal(sv));
4168             break;
4169         }
4170         if (checksum) {
4171             sv = NEWSV(42, 0);
4172             if (strchr("fFdD", datumtype) ||
4173               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4174                 NV trouble;
4175
4176                 adouble = 1.0;
4177                 while (checksum >= 16) {
4178                     checksum -= 16;
4179                     adouble *= 65536.0;
4180                 }
4181                 while (checksum >= 4) {
4182                     checksum -= 4;
4183                     adouble *= 16.0;
4184                 }
4185                 while (checksum--)
4186                     adouble *= 2.0;
4187                 along = (1 << checksum) - 1;
4188                 while (cdouble < 0.0)
4189                     cdouble += adouble;
4190                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4191                 sv_setnv(sv, cdouble);
4192             }
4193             else {
4194                 if (checksum < 32) {
4195                     aulong = (1 << checksum) - 1;
4196                     culong &= aulong;
4197                 }
4198                 sv_setuv(sv, (UV)culong);
4199             }
4200             XPUSHs(sv_2mortal(sv));
4201             checksum = 0;
4202         }
4203     }
4204     if (SP == oldsp && gimme == G_SCALAR)
4205         PUSHs(&PL_sv_undef);
4206     RETURN;
4207 }
4208
4209 STATIC void
4210 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4211 {
4212     char hunk[5];
4213
4214     *hunk = PL_uuemap[len];
4215     sv_catpvn(sv, hunk, 1);
4216     hunk[4] = '\0';
4217     while (len > 2) {
4218         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4219         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4220         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4221         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4222         sv_catpvn(sv, hunk, 4);
4223         s += 3;
4224         len -= 3;
4225     }
4226     if (len > 0) {
4227         char r = (len > 1 ? s[1] : '\0');
4228         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4229         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4230         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4231         hunk[3] = PL_uuemap[0];
4232         sv_catpvn(sv, hunk, 4);
4233     }
4234     sv_catpvn(sv, "\n", 1);
4235 }
4236
4237 STATIC SV *
4238 S_is_an_int(pTHX_ char *s, STRLEN l)
4239 {
4240   STRLEN         n_a;
4241   SV             *result = newSVpvn(s, l);
4242   char           *result_c = SvPV(result, n_a); /* convenience */
4243   char           *out = result_c;
4244   bool            skip = 1;
4245   bool            ignore = 0;
4246
4247   while (*s) {
4248     switch (*s) {
4249     case ' ':
4250       break;
4251     case '+':
4252       if (!skip) {
4253         SvREFCNT_dec(result);
4254         return (NULL);
4255       }
4256       break;
4257     case '0':
4258     case '1':
4259     case '2':
4260     case '3':
4261     case '4':
4262     case '5':
4263     case '6':
4264     case '7':
4265     case '8':
4266     case '9':
4267       skip = 0;
4268       if (!ignore) {
4269         *(out++) = *s;
4270       }
4271       break;
4272     case '.':
4273       ignore = 1;
4274       break;
4275     default:
4276       SvREFCNT_dec(result);
4277       return (NULL);
4278     }
4279     s++;
4280   }
4281   *(out++) = '\0';
4282   SvCUR_set(result, out - result_c);
4283   return (result);
4284 }
4285
4286 /* pnum must be '\0' terminated */
4287 STATIC int
4288 S_div128(pTHX_ SV *pnum, bool *done)
4289 {
4290   STRLEN          len;
4291   char           *s = SvPV(pnum, len);
4292   int             m = 0;
4293   int             r = 0;
4294   char           *t = s;
4295
4296   *done = 1;
4297   while (*t) {
4298     int             i;
4299
4300     i = m * 10 + (*t - '0');
4301     m = i & 0x7F;
4302     r = (i >> 7);               /* r < 10 */
4303     if (r) {
4304       *done = 0;
4305     }
4306     *(t++) = '0' + r;
4307   }
4308   *(t++) = '\0';
4309   SvCUR_set(pnum, (STRLEN) (t - s));
4310   return (m);
4311 }
4312
4313
4314 PP(pp_pack)
4315 {
4316     djSP; dMARK; dORIGMARK; dTARGET;
4317     register SV *cat = TARG;
4318     register I32 items;
4319     STRLEN fromlen;
4320     register char *pat = SvPVx(*++MARK, fromlen);
4321     register char *patend = pat + fromlen;
4322     register I32 len;
4323     I32 datumtype;
4324     SV *fromstr;
4325     /*SUPPRESS 442*/
4326     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4327     static char *space10 = "          ";
4328
4329     /* These must not be in registers: */
4330     char achar;
4331     I16 ashort;
4332     int aint;
4333     unsigned int auint;
4334     I32 along;
4335     U32 aulong;
4336 #ifdef HAS_QUAD
4337     Quad_t aquad;
4338     Uquad_t auquad;
4339 #endif
4340     char *aptr;
4341     float afloat;
4342     double adouble;
4343     int commas = 0;
4344 #ifdef PERL_NATINT_PACK
4345     int natint;         /* native integer */
4346 #endif
4347
4348     items = SP - MARK;
4349     MARK++;
4350     sv_setpvn(cat, "", 0);
4351     while (pat < patend) {
4352 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4353         datumtype = *pat++ & 0xFF;
4354 #ifdef PERL_NATINT_PACK
4355         natint = 0;
4356 #endif
4357         if (isSPACE(datumtype))
4358             continue;
4359         if (*pat == '!') {
4360             char *natstr = "sSiIlL";
4361
4362             if (strchr(natstr, datumtype)) {
4363 #ifdef PERL_NATINT_PACK
4364                 natint = 1;
4365 #endif
4366                 pat++;
4367             }
4368             else
4369                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4370         }
4371         if (*pat == '*') {
4372             len = strchr("@Xxu", datumtype) ? 0 : items;
4373             pat++;
4374         }
4375         else if (isDIGIT(*pat)) {
4376             len = *pat++ - '0';
4377             while (isDIGIT(*pat))
4378                 len = (len * 10) + (*pat++ - '0');
4379         }
4380         else
4381             len = 1;
4382         switch(datumtype) {
4383         default:
4384             Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4385         case ',': /* grandfather in commas but with a warning */
4386             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4387                 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4388             break;
4389         case '%':
4390             DIE(aTHX_ "%% may only be used in unpack");
4391         case '@':
4392             len -= SvCUR(cat);
4393             if (len > 0)
4394                 goto grow;
4395             len = -len;
4396             if (len > 0)
4397                 goto shrink;
4398             break;
4399         case 'X':
4400           shrink:
4401             if (SvCUR(cat) < len)
4402                 DIE(aTHX_ "X outside of string");
4403             SvCUR(cat) -= len;
4404             *SvEND(cat) = '\0';
4405             break;
4406         case 'x':
4407           grow:
4408             while (len >= 10) {
4409                 sv_catpvn(cat, null10, 10);
4410                 len -= 10;
4411             }
4412             sv_catpvn(cat, null10, len);
4413             break;
4414         case 'A':
4415         case 'Z':
4416         case 'a':
4417             fromstr = NEXTFROM;
4418             aptr = SvPV(fromstr, fromlen);
4419             if (pat[-1] == '*')
4420                 len = fromlen;
4421             if (fromlen > len)
4422                 sv_catpvn(cat, aptr, len);
4423             else {
4424                 sv_catpvn(cat, aptr, fromlen);
4425                 len -= fromlen;
4426                 if (datumtype == 'A') {
4427                     while (len >= 10) {
4428                         sv_catpvn(cat, space10, 10);
4429                         len -= 10;
4430                     }
4431                     sv_catpvn(cat, space10, len);
4432                 }
4433                 else {
4434                     while (len >= 10) {
4435                         sv_catpvn(cat, null10, 10);
4436                         len -= 10;
4437                     }
4438                     sv_catpvn(cat, null10, len);
4439                 }
4440             }
4441             break;
4442         case 'B':
4443         case 'b':
4444             {
4445                 char *savepat = pat;
4446                 I32 saveitems;
4447
4448                 fromstr = NEXTFROM;
4449                 saveitems = items;
4450                 aptr = SvPV(fromstr, fromlen);
4451                 if (pat[-1] == '*')
4452                     len = fromlen;
4453                 pat = aptr;
4454                 aint = SvCUR(cat);
4455                 SvCUR(cat) += (len+7)/8;
4456                 SvGROW(cat, SvCUR(cat) + 1);
4457                 aptr = SvPVX(cat) + aint;
4458                 if (len > fromlen)
4459                     len = fromlen;
4460                 aint = len;
4461                 items = 0;
4462                 if (datumtype == 'B') {
4463                     for (len = 0; len++ < aint;) {
4464                         items |= *pat++ & 1;
4465                         if (len & 7)
4466                             items <<= 1;
4467                         else {
4468                             *aptr++ = items & 0xff;
4469                             items = 0;
4470                         }
4471                     }
4472                 }
4473                 else {
4474                     for (len = 0; len++ < aint;) {
4475                         if (*pat++ & 1)
4476                             items |= 128;
4477                         if (len & 7)
4478                             items >>= 1;
4479                         else {
4480                             *aptr++ = items & 0xff;
4481                             items = 0;
4482                         }
4483                     }
4484                 }
4485                 if (aint & 7) {
4486                     if (datumtype == 'B')
4487                         items <<= 7 - (aint & 7);
4488                     else
4489                         items >>= 7 - (aint & 7);
4490                     *aptr++ = items & 0xff;
4491                 }
4492                 pat = SvPVX(cat) + SvCUR(cat);
4493                 while (aptr <= pat)
4494                     *aptr++ = '\0';
4495
4496                 pat = savepat;
4497                 items = saveitems;
4498             }
4499             break;
4500         case 'H':
4501         case 'h':
4502             {
4503                 char *savepat = pat;
4504                 I32 saveitems;
4505
4506                 fromstr = NEXTFROM;
4507                 saveitems = items;
4508                 aptr = SvPV(fromstr, fromlen);
4509                 if (pat[-1] == '*')
4510                     len = fromlen;
4511                 pat = aptr;
4512                 aint = SvCUR(cat);
4513                 SvCUR(cat) += (len+1)/2;
4514                 SvGROW(cat, SvCUR(cat) + 1);
4515                 aptr = SvPVX(cat) + aint;
4516                 if (len > fromlen)
4517                     len = fromlen;
4518                 aint = len;
4519                 items = 0;
4520                 if (datumtype == 'H') {
4521                     for (len = 0; len++ < aint;) {
4522                         if (isALPHA(*pat))
4523                             items |= ((*pat++ & 15) + 9) & 15;
4524                         else
4525                             items |= *pat++ & 15;
4526                         if (len & 1)
4527                             items <<= 4;
4528                         else {
4529                             *aptr++ = items & 0xff;
4530                             items = 0;
4531                         }
4532                     }
4533                 }
4534                 else {
4535                     for (len = 0; len++ < aint;) {
4536                         if (isALPHA(*pat))
4537                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4538                         else
4539                             items |= (*pat++ & 15) << 4;
4540                         if (len & 1)
4541                             items >>= 4;
4542                         else {
4543                             *aptr++ = items & 0xff;
4544                             items = 0;
4545                         }
4546                     }
4547                 }
4548                 if (aint & 1)
4549                     *aptr++ = items & 0xff;
4550                 pat = SvPVX(cat) + SvCUR(cat);
4551                 while (aptr <= pat)
4552                     *aptr++ = '\0';
4553
4554                 pat = savepat;
4555                 items = saveitems;
4556             }
4557             break;
4558         case 'C':
4559         case 'c':
4560             while (len-- > 0) {
4561                 fromstr = NEXTFROM;
4562                 aint = SvIV(fromstr);
4563                 achar = aint;
4564                 sv_catpvn(cat, &achar, sizeof(char));
4565             }
4566             break;
4567         case 'U':
4568             while (len-- > 0) {
4569                 fromstr = NEXTFROM;
4570                 auint = SvUV(fromstr);
4571                 SvGROW(cat, SvCUR(cat) + 10);
4572                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4573                                - SvPVX(cat));
4574             }
4575             *SvEND(cat) = '\0';
4576             break;
4577         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4578         case 'f':
4579         case 'F':
4580             while (len-- > 0) {
4581                 fromstr = NEXTFROM;
4582                 afloat = (float)SvNV(fromstr);
4583                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4584             }
4585             break;
4586         case 'd':
4587         case 'D':
4588             while (len-- > 0) {
4589                 fromstr = NEXTFROM;
4590                 adouble = (double)SvNV(fromstr);
4591                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4592             }
4593             break;
4594         case 'n':
4595             while (len-- > 0) {
4596                 fromstr = NEXTFROM;
4597                 ashort = (I16)SvIV(fromstr);
4598 #ifdef HAS_HTONS
4599                 ashort = PerlSock_htons(ashort);
4600 #endif
4601                 CAT16(cat, &ashort);
4602             }
4603             break;
4604         case 'v':
4605             while (len-- > 0) {
4606                 fromstr = NEXTFROM;
4607                 ashort = (I16)SvIV(fromstr);
4608 #ifdef HAS_HTOVS
4609                 ashort = htovs(ashort);
4610 #endif
4611                 CAT16(cat, &ashort);
4612             }
4613             break;
4614         case 'S':
4615 #if SHORTSIZE != SIZE16
4616             if (natint) {
4617                 unsigned short aushort;
4618
4619                 while (len-- > 0) {
4620                     fromstr = NEXTFROM;
4621                     aushort = SvUV(fromstr);
4622                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4623                 }
4624             }
4625             else
4626 #endif
4627             {
4628                 U16 aushort;
4629
4630                 while (len-- > 0) {
4631                     fromstr = NEXTFROM;
4632                     aushort = (U16)SvUV(fromstr);
4633                     CAT16(cat, &aushort);
4634                 }
4635
4636             }
4637             break;
4638         case 's':
4639 #if SHORTSIZE != SIZE16
4640             if (natint) {
4641                 while (len-- > 0) {
4642                     fromstr = NEXTFROM;
4643                     ashort = SvIV(fromstr);
4644                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4645                 }
4646             }
4647             else
4648 #endif
4649             {
4650                 while (len-- > 0) {
4651                     fromstr = NEXTFROM;
4652                     ashort = (I16)SvIV(fromstr);
4653                     CAT16(cat, &ashort);
4654                 }
4655             }
4656             break;
4657         case 'I':
4658             while (len-- > 0) {
4659                 fromstr = NEXTFROM;
4660                 auint = SvUV(fromstr);
4661                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4662             }
4663             break;
4664         case 'w':
4665             while (len-- > 0) {
4666                 fromstr = NEXTFROM;
4667                 adouble = Perl_floor(SvNV(fromstr));
4668
4669                 if (adouble < 0)
4670                     Perl_croak(aTHX_ "Cannot compress negative numbers");
4671
4672                 if (
4673 #ifdef BW_BITS
4674                     adouble <= BW_MASK
4675 #else
4676 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4677                     adouble <= UV_MAX_cxux
4678 #else
4679                     adouble <= UV_MAX
4680 #endif
4681 #endif
4682                     )
4683                 {
4684                     char   buf[1 + sizeof(UV)];
4685                     char  *in = buf + sizeof(buf);
4686                     UV     auv = U_V(adouble);
4687
4688                     do {
4689                         *--in = (auv & 0x7f) | 0x80;
4690                         auv >>= 7;
4691                     } while (auv);
4692                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4693                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4694                 }
4695                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4696                     char           *from, *result, *in;
4697                     SV             *norm;
4698                     STRLEN          len;
4699                     bool            done;
4700
4701                     /* Copy string and check for compliance */
4702                     from = SvPV(fromstr, len);
4703                     if ((norm = is_an_int(from, len)) == NULL)
4704                         Perl_croak(aTHX_ "can compress only unsigned integer");
4705
4706                     New('w', result, len, char);
4707                     in = result + len;
4708                     done = FALSE;
4709                     while (!done)
4710                         *--in = div128(norm, &done) | 0x80;
4711                     result[len - 1] &= 0x7F; /* clear continue bit */
4712                     sv_catpvn(cat, in, (result + len) - in);
4713                     Safefree(result);
4714                     SvREFCNT_dec(norm); /* free norm */
4715                 }
4716                 else if (SvNOKp(fromstr)) {
4717                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4718                     char  *in = buf + sizeof(buf);
4719
4720                     do {
4721                         double next = floor(adouble / 128);
4722                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4723                         if (--in < buf)  /* this cannot happen ;-) */
4724                             Perl_croak(aTHX_ "Cannot compress integer");
4725                         adouble = next;
4726                     } while (adouble > 0);
4727                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4728                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4729                 }
4730                 else
4731                     Perl_croak(aTHX_ "Cannot compress non integer");
4732             }
4733             break;
4734         case 'i':
4735             while (len-- > 0) {
4736                 fromstr = NEXTFROM;
4737                 aint = SvIV(fromstr);
4738                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4739             }
4740             break;
4741         case 'N':
4742             while (len-- > 0) {
4743                 fromstr = NEXTFROM;
4744                 aulong = SvUV(fromstr);
4745 #ifdef HAS_HTONL
4746                 aulong = PerlSock_htonl(aulong);
4747 #endif
4748                 CAT32(cat, &aulong);
4749             }
4750             break;
4751         case 'V':
4752             while (len-- > 0) {
4753                 fromstr = NEXTFROM;
4754                 aulong = SvUV(fromstr);
4755 #ifdef HAS_HTOVL
4756                 aulong = htovl(aulong);
4757 #endif
4758                 CAT32(cat, &aulong);
4759             }
4760             break;
4761         case 'L':
4762 #if LONGSIZE != SIZE32
4763             if (natint) {
4764                 while (len-- > 0) {
4765                     fromstr = NEXTFROM;
4766                     aulong = SvUV(fromstr);
4767                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4768                 }
4769             }
4770             else
4771 #endif
4772             {
4773                 while (len-- > 0) {
4774                     fromstr = NEXTFROM;
4775                     aulong = SvUV(fromstr);
4776                     CAT32(cat, &aulong);
4777                 }
4778             }
4779             break;
4780         case 'l':
4781 #if LONGSIZE != SIZE32
4782             if (natint) {
4783                 while (len-- > 0) {
4784                     fromstr = NEXTFROM;
4785                     along = SvIV(fromstr);
4786                     sv_catpvn(cat, (char *)&along, sizeof(long));
4787                 }
4788             }
4789             else
4790 #endif
4791             {
4792                 while (len-- > 0) {
4793                     fromstr = NEXTFROM;
4794                     along = SvIV(fromstr);
4795                     CAT32(cat, &along);
4796                 }
4797             }
4798             break;
4799 #ifdef HAS_QUAD
4800         case 'Q':
4801             while (len-- > 0) {
4802                 fromstr = NEXTFROM;
4803                 auquad = (Uquad_t)SvIV(fromstr);
4804                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4805             }
4806             break;
4807         case 'q':
4808             while (len-- > 0) {
4809                 fromstr = NEXTFROM;
4810                 aquad = (Quad_t)SvIV(fromstr);
4811                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4812             }
4813             break;
4814 #endif /* HAS_QUAD */
4815         case 'P':
4816             len = 1;            /* assume SV is correct length */
4817             /* FALL THROUGH */
4818         case 'p':
4819             while (len-- > 0) {
4820                 fromstr = NEXTFROM;
4821                 if (fromstr == &PL_sv_undef)
4822                     aptr = NULL;
4823                 else {
4824                     STRLEN n_a;
4825                     /* XXX better yet, could spirit away the string to
4826                      * a safe spot and hang on to it until the result
4827                      * of pack() (and all copies of the result) are
4828                      * gone.
4829                      */
4830                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4831                         Perl_warner(aTHX_ WARN_UNSAFE,
4832                                 "Attempt to pack pointer to temporary value");
4833                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4834                         aptr = SvPV(fromstr,n_a);
4835                     else
4836                         aptr = SvPV_force(fromstr,n_a);
4837                 }
4838                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4839             }
4840             break;
4841         case 'u':
4842             fromstr = NEXTFROM;
4843             aptr = SvPV(fromstr, fromlen);
4844             SvGROW(cat, fromlen * 4 / 3);
4845             if (len <= 1)
4846                 len = 45;
4847             else
4848                 len = len / 3 * 3;
4849             while (fromlen > 0) {
4850                 I32 todo;
4851
4852                 if (fromlen > len)
4853                     todo = len;
4854                 else
4855                     todo = fromlen;
4856                 doencodes(cat, aptr, todo);
4857                 fromlen -= todo;
4858                 aptr += todo;
4859             }
4860             break;
4861         }
4862     }
4863     SvSETMAGIC(cat);
4864     SP = ORIGMARK;
4865     PUSHs(cat);
4866     RETURN;
4867 }
4868 #undef NEXTFROM
4869
4870
4871 PP(pp_split)
4872 {
4873     djSP; dTARG;
4874     AV *ary;
4875     register I32 limit = POPi;                  /* note, negative is forever */
4876     SV *sv = POPs;
4877     STRLEN len;
4878     register char *s = SvPV(sv, len);
4879     char *strend = s + len;
4880     register PMOP *pm;
4881     register REGEXP *rx;
4882     register SV *dstr;
4883     register char *m;
4884     I32 iters = 0;
4885     I32 maxiters = (strend - s) + 10;
4886     I32 i;
4887     char *orig;
4888     I32 origlimit = limit;
4889     I32 realarray = 0;
4890     I32 base;
4891     AV *oldstack = PL_curstack;
4892     I32 gimme = GIMME_V;
4893     I32 oldsave = PL_savestack_ix;
4894     I32 make_mortal = 1;
4895     MAGIC *mg = (MAGIC *) NULL;
4896
4897 #ifdef DEBUGGING
4898     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4899 #else
4900     pm = (PMOP*)POPs;
4901 #endif
4902     if (!pm || !s)
4903         DIE(aTHX_ "panic: do_split");
4904     rx = pm->op_pmregexp;
4905
4906     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4907              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4908
4909     if (pm->op_pmreplroot)
4910         ary = GvAVn((GV*)pm->op_pmreplroot);
4911     else if (gimme != G_ARRAY)
4912 #ifdef USE_THREADS
4913         ary = (AV*)PL_curpad[0];
4914 #else
4915         ary = GvAVn(PL_defgv);
4916 #endif /* USE_THREADS */
4917     else
4918         ary = Nullav;
4919     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4920         realarray = 1;
4921         PUTBACK;
4922         av_extend(ary,0);
4923         av_clear(ary);
4924         SPAGAIN;
4925         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4926             PUSHMARK(SP);
4927             XPUSHs(SvTIED_obj((SV*)ary, mg));
4928         }
4929         else {
4930             if (!AvREAL(ary)) {
4931                 AvREAL_on(ary);
4932                 for (i = AvFILLp(ary); i >= 0; i--)
4933                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4934             }
4935             /* temporarily switch stacks */
4936             SWITCHSTACK(PL_curstack, ary);
4937             make_mortal = 0;
4938         }
4939     }
4940     base = SP - PL_stack_base;
4941     orig = s;
4942     if (pm->op_pmflags & PMf_SKIPWHITE) {
4943         if (pm->op_pmflags & PMf_LOCALE) {
4944             while (isSPACE_LC(*s))
4945                 s++;
4946         }
4947         else {
4948             while (isSPACE(*s))
4949                 s++;
4950         }
4951     }
4952     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4953         SAVEINT(PL_multiline);
4954         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4955     }
4956
4957     if (!limit)
4958         limit = maxiters + 2;
4959     if (pm->op_pmflags & PMf_WHITE) {
4960         while (--limit) {
4961             m = s;
4962             while (m < strend &&
4963                    !((pm->op_pmflags & PMf_LOCALE)
4964                      ? isSPACE_LC(*m) : isSPACE(*m)))
4965                 ++m;
4966             if (m >= strend)
4967                 break;
4968
4969             dstr = NEWSV(30, m-s);
4970             sv_setpvn(dstr, s, m-s);
4971             if (make_mortal)
4972                 sv_2mortal(dstr);
4973             XPUSHs(dstr);
4974
4975             s = m + 1;
4976             while (s < strend &&
4977                    ((pm->op_pmflags & PMf_LOCALE)
4978                     ? isSPACE_LC(*s) : isSPACE(*s)))
4979                 ++s;
4980         }
4981     }
4982     else if (strEQ("^", rx->precomp)) {
4983         while (--limit) {
4984             /*SUPPRESS 530*/
4985             for (m = s; m < strend && *m != '\n'; m++) ;
4986             m++;
4987             if (m >= strend)
4988                 break;
4989             dstr = NEWSV(30, m-s);
4990             sv_setpvn(dstr, s, m-s);
4991             if (make_mortal)
4992                 sv_2mortal(dstr);
4993             XPUSHs(dstr);
4994             s = m;
4995         }
4996     }
4997     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
4998              && (rx->reganch & ROPT_CHECK_ALL)
4999              && !(rx->reganch & ROPT_ANCH)) {
5000         int tail = (rx->reganch & RE_INTUIT_TAIL);
5001         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5002         char c;
5003
5004         len = rx->minlen;
5005         if (len == 1 && !tail) {
5006             c = *SvPV(csv,len);
5007             while (--limit) {
5008                 /*SUPPRESS 530*/
5009                 for (m = s; m < strend && *m != c; m++) ;
5010                 if (m >= strend)
5011                     break;
5012                 dstr = NEWSV(30, m-s);
5013                 sv_setpvn(dstr, s, m-s);
5014                 if (make_mortal)
5015                     sv_2mortal(dstr);
5016                 XPUSHs(dstr);
5017                 s = m + 1;
5018             }
5019         }
5020         else {
5021 #ifndef lint
5022             while (s < strend && --limit &&
5023               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5024                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5025 #endif
5026             {
5027                 dstr = NEWSV(31, m-s);
5028                 sv_setpvn(dstr, s, m-s);
5029                 if (make_mortal)
5030                     sv_2mortal(dstr);
5031                 XPUSHs(dstr);
5032                 s = m + len;            /* Fake \n at the end */
5033             }
5034         }
5035     }
5036     else {
5037         maxiters += (strend - s) * rx->nparens;
5038         while (s < strend && --limit
5039 /*             && (!rx->check_substr
5040                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5041                                                  0, NULL))))
5042 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5043                               1 /* minend */, sv, NULL, 0))
5044         {
5045             TAINT_IF(RX_MATCH_TAINTED(rx));
5046             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5047                 m = s;
5048                 s = orig;
5049                 orig = rx->subbeg;
5050                 s = orig + (m - s);
5051                 strend = s + (strend - m);
5052             }
5053             m = rx->startp[0] + orig;
5054             dstr = NEWSV(32, m-s);
5055             sv_setpvn(dstr, s, m-s);
5056             if (make_mortal)
5057                 sv_2mortal(dstr);
5058             XPUSHs(dstr);
5059             if (rx->nparens) {
5060                 for (i = 1; i <= rx->nparens; i++) {
5061                     s = rx->startp[i] + orig;
5062                     m = rx->endp[i] + orig;
5063                     if (m && s) {
5064                         dstr = NEWSV(33, m-s);
5065                         sv_setpvn(dstr, s, m-s);
5066                     }
5067                     else
5068                         dstr = NEWSV(33, 0);
5069                     if (make_mortal)
5070                         sv_2mortal(dstr);
5071                     XPUSHs(dstr);
5072                 }
5073             }
5074             s = rx->endp[0] + orig;
5075         }
5076     }
5077
5078     LEAVE_SCOPE(oldsave);
5079     iters = (SP - PL_stack_base) - base;
5080     if (iters > maxiters)
5081         DIE(aTHX_ "Split loop");
5082
5083     /* keep field after final delim? */
5084     if (s < strend || (iters && origlimit)) {
5085         dstr = NEWSV(34, strend-s);
5086         sv_setpvn(dstr, s, strend-s);
5087         if (make_mortal)
5088             sv_2mortal(dstr);
5089         XPUSHs(dstr);
5090         iters++;
5091     }
5092     else if (!origlimit) {
5093         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5094             iters--, SP--;
5095     }
5096
5097     if (realarray) {
5098         if (!mg) {
5099             SWITCHSTACK(ary, oldstack);
5100             if (SvSMAGICAL(ary)) {
5101                 PUTBACK;
5102                 mg_set((SV*)ary);
5103                 SPAGAIN;
5104             }
5105             if (gimme == G_ARRAY) {
5106                 EXTEND(SP, iters);
5107                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5108                 SP += iters;
5109                 RETURN;
5110             }
5111         }
5112         else {
5113             PUTBACK;
5114             ENTER;
5115             call_method("PUSH",G_SCALAR|G_DISCARD);
5116             LEAVE;
5117             SPAGAIN;
5118             if (gimme == G_ARRAY) {
5119                 /* EXTEND should not be needed - we just popped them */
5120                 EXTEND(SP, iters);
5121                 for (i=0; i < iters; i++) {
5122                     SV **svp = av_fetch(ary, i, FALSE);
5123                     PUSHs((svp) ? *svp : &PL_sv_undef);
5124                 }
5125                 RETURN;
5126             }
5127         }
5128     }
5129     else {
5130         if (gimme == G_ARRAY)
5131             RETURN;
5132     }
5133     if (iters || !pm->op_pmreplroot) {
5134         GETTARGET;
5135         PUSHi(iters);
5136         RETURN;
5137     }
5138     RETPUSHUNDEF;
5139 }
5140
5141 #ifdef USE_THREADS
5142 void
5143 Perl_unlock_condpair(pTHX_ void *svv)
5144 {
5145     dTHR;
5146     MAGIC *mg = mg_find((SV*)svv, 'm');
5147
5148     if (!mg)
5149         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5150     MUTEX_LOCK(MgMUTEXP(mg));
5151     if (MgOWNER(mg) != thr)
5152         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5153     MgOWNER(mg) = 0;
5154     COND_SIGNAL(MgOWNERCONDP(mg));
5155     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5156                           (unsigned long)thr, (unsigned long)svv);)
5157     MUTEX_UNLOCK(MgMUTEXP(mg));
5158 }
5159 #endif /* USE_THREADS */
5160
5161 PP(pp_lock)
5162 {
5163     djSP;
5164     dTOPss;
5165     SV *retsv = sv;
5166 #ifdef USE_THREADS
5167     MAGIC *mg;
5168
5169     if (SvROK(sv))
5170         sv = SvRV(sv);
5171
5172     mg = condpair_magic(sv);
5173     MUTEX_LOCK(MgMUTEXP(mg));
5174     if (MgOWNER(mg) == thr)
5175         MUTEX_UNLOCK(MgMUTEXP(mg));
5176     else {
5177         while (MgOWNER(mg))
5178             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5179         MgOWNER(mg) = thr;
5180         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5181                               (unsigned long)thr, (unsigned long)sv);)
5182         MUTEX_UNLOCK(MgMUTEXP(mg));
5183         SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5184     }
5185 #endif /* USE_THREADS */
5186     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5187         || SvTYPE(retsv) == SVt_PVCV) {
5188         retsv = refto(retsv);
5189     }
5190     SETs(retsv);
5191     RETURN;
5192 }
5193
5194 PP(pp_threadsv)
5195 {
5196     djSP;
5197 #ifdef USE_THREADS
5198     EXTEND(SP, 1);
5199     if (PL_op->op_private & OPpLVAL_INTRO)
5200         PUSHs(*save_threadsv(PL_op->op_targ));
5201     else
5202         PUSHs(THREADSV(PL_op->op_targ));
5203     RETURN;
5204 #else
5205     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5206 #endif /* USE_THREADS */
5207 }