pp.c

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