pp.c

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