pp.c

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