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