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