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