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