pp.c

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