pp.c

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