pp.c

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