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