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