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                     while (len-- > 0) {
3940                         COPYNN(s, &along, sizeof(long));
3941                         s += sizeof(long);
3942                         if (checksum > 32)
3943                             cdouble += (NV)along;
3944                         else
3945                             culong += along;
3946                     }
3947                 }
3948                 else
3949 #endif
3950                 {
3951                     while (len-- > 0) {
3952 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3953                         I32 along;
3954 #endif
3955                         COPY32(s, &along);
3956 #if LONGSIZE > SIZE32
3957                         if (along > 2147483647)
3958                           along -= 4294967296;
3959 #endif
3960                         s += SIZE32;
3961                         if (checksum > 32)
3962                             cdouble += (NV)along;
3963                         else
3964                             culong += along;
3965                     }
3966                 }
3967             }
3968             else {
3969                 EXTEND(SP, len);
3970                 EXTEND_MORTAL(len);
3971 #if LONGSIZE != SIZE32
3972                 if (natint) {
3973                     while (len-- > 0) {
3974                         COPYNN(s, &along, sizeof(long));
3975                         s += sizeof(long);
3976                         sv = NEWSV(42, 0);
3977                         sv_setiv(sv, (IV)along);
3978                         PUSHs(sv_2mortal(sv));
3979                     }
3980                 }
3981                 else
3982 #endif
3983                 {
3984                     while (len-- > 0) {
3985 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3986                         I32 along;
3987 #endif
3988                         COPY32(s, &along);
3989 #if LONGSIZE > SIZE32
3990                         if (along > 2147483647)
3991                           along -= 4294967296;
3992 #endif
3993                         s += SIZE32;
3994                         sv = NEWSV(42, 0);
3995                         sv_setiv(sv, (IV)along);
3996                         PUSHs(sv_2mortal(sv));
3997                     }
3998                 }
3999             }
4000             break;
4001         case 'V':
4002         case 'N':
4003         case 'L':
4004 #if LONGSIZE == SIZE32
4005             along = (strend - s) / SIZE32;
4006 #else
4007             unatint = natint && datumtype == 'L';
4008             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4009 #endif
4010             if (len > along)
4011                 len = along;
4012             if (checksum) {
4013 #if LONGSIZE != SIZE32
4014                 if (unatint) {
4015                     unsigned long aulong;
4016                     while (len-- > 0) {
4017                         COPYNN(s, &aulong, sizeof(unsigned long));
4018                         s += sizeof(unsigned long);
4019                         if (checksum > 32)
4020                             cdouble += (NV)aulong;
4021                         else
4022                             culong += aulong;
4023                     }
4024                 }
4025                 else
4026 #endif
4027                 {
4028                     while (len-- > 0) {
4029                         COPY32(s, &aulong);
4030                         s += SIZE32;
4031 #ifdef HAS_NTOHL
4032                         if (datumtype == 'N')
4033                             aulong = PerlSock_ntohl(aulong);
4034 #endif
4035 #ifdef HAS_VTOHL
4036                         if (datumtype == 'V')
4037                             aulong = vtohl(aulong);
4038 #endif
4039                         if (checksum > 32)
4040                             cdouble += (NV)aulong;
4041                         else
4042                             culong += aulong;
4043                     }
4044                 }
4045             }
4046             else {
4047                 EXTEND(SP, len);
4048                 EXTEND_MORTAL(len);
4049 #if LONGSIZE != SIZE32
4050                 if (unatint) {
4051                     unsigned long aulong;
4052                     while (len-- > 0) {
4053                         COPYNN(s, &aulong, sizeof(unsigned long));
4054                         s += sizeof(unsigned long);
4055                         sv = NEWSV(43, 0);
4056                         sv_setuv(sv, (UV)aulong);
4057                         PUSHs(sv_2mortal(sv));
4058                     }
4059                 }
4060                 else
4061 #endif
4062                 {
4063                     while (len-- > 0) {
4064                         COPY32(s, &aulong);
4065                         s += SIZE32;
4066 #ifdef HAS_NTOHL
4067                         if (datumtype == 'N')
4068                             aulong = PerlSock_ntohl(aulong);
4069 #endif
4070 #ifdef HAS_VTOHL
4071                         if (datumtype == 'V')
4072                             aulong = vtohl(aulong);
4073 #endif
4074                         sv = NEWSV(43, 0);
4075                         sv_setuv(sv, (UV)aulong);
4076                         PUSHs(sv_2mortal(sv));
4077                     }
4078                 }
4079             }
4080             break;
4081         case 'p':
4082             along = (strend - s) / sizeof(char*);
4083             if (len > along)
4084                 len = along;
4085             EXTEND(SP, len);
4086             EXTEND_MORTAL(len);
4087             while (len-- > 0) {
4088                 if (sizeof(char*) > strend - s)
4089                     break;
4090                 else {
4091                     Copy(s, &aptr, 1, char*);
4092                     s += sizeof(char*);
4093                 }
4094                 sv = NEWSV(44, 0);
4095                 if (aptr)
4096                     sv_setpv(sv, aptr);
4097                 PUSHs(sv_2mortal(sv));
4098             }
4099             break;
4100         case 'w':
4101             EXTEND(SP, len);
4102             EXTEND_MORTAL(len);
4103             {
4104                 UV auv = 0;
4105                 U32 bytes = 0;
4106
4107                 while ((len > 0) && (s < strend)) {
4108                     auv = (auv << 7) | (*s & 0x7f);
4109                     if (!(*s++ & 0x80)) {
4110                         bytes = 0;
4111                         sv = NEWSV(40, 0);
4112                         sv_setuv(sv, auv);
4113                         PUSHs(sv_2mortal(sv));
4114                         len--;
4115                         auv = 0;
4116                     }
4117                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4118                         char *t;
4119                         STRLEN n_a;
4120
4121                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4122                         while (s < strend) {
4123                             sv = mul128(sv, *s & 0x7f);
4124                             if (!(*s++ & 0x80)) {
4125                                 bytes = 0;
4126                                 break;
4127                             }
4128                         }
4129                         t = SvPV(sv, n_a);
4130                         while (*t == '0')
4131                             t++;
4132                         sv_chop(sv, t);
4133                         PUSHs(sv_2mortal(sv));
4134                         len--;
4135                         auv = 0;
4136                     }
4137                 }
4138                 if ((s >= strend) && bytes)
4139                     DIE(aTHX_ "Unterminated compressed integer");
4140             }
4141             break;
4142         case 'P':
4143             EXTEND(SP, 1);
4144             if (sizeof(char*) > strend - s)
4145                 break;
4146             else {
4147                 Copy(s, &aptr, 1, char*);
4148                 s += sizeof(char*);
4149             }
4150             sv = NEWSV(44, 0);
4151             if (aptr)
4152                 sv_setpvn(sv, aptr, len);
4153             PUSHs(sv_2mortal(sv));
4154             break;
4155 #ifdef HAS_QUAD
4156         case 'q':
4157             along = (strend - s) / sizeof(Quad_t);
4158             if (len > along)
4159                 len = along;
4160             EXTEND(SP, len);
4161             EXTEND_MORTAL(len);
4162             while (len-- > 0) {
4163                 if (s + sizeof(Quad_t) > strend)
4164                     aquad = 0;
4165                 else {
4166                     Copy(s, &aquad, 1, Quad_t);
4167                     s += sizeof(Quad_t);
4168                 }
4169                 sv = NEWSV(42, 0);
4170                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4171                     sv_setiv(sv, (IV)aquad);
4172                 else
4173                     sv_setnv(sv, (NV)aquad);
4174                 PUSHs(sv_2mortal(sv));
4175             }
4176             break;
4177         case 'Q':
4178             along = (strend - s) / sizeof(Quad_t);
4179             if (len > along)
4180                 len = along;
4181             EXTEND(SP, len);
4182             EXTEND_MORTAL(len);
4183             while (len-- > 0) {
4184                 if (s + sizeof(Uquad_t) > strend)
4185                     auquad = 0;
4186                 else {
4187                     Copy(s, &auquad, 1, Uquad_t);
4188                     s += sizeof(Uquad_t);
4189                 }
4190                 sv = NEWSV(43, 0);
4191                 if (auquad <= UV_MAX)
4192                     sv_setuv(sv, (UV)auquad);
4193                 else
4194                     sv_setnv(sv, (NV)auquad);
4195                 PUSHs(sv_2mortal(sv));
4196             }
4197             break;
4198 #endif
4199         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4200         case 'f':
4201         case 'F':
4202             along = (strend - s) / sizeof(float);
4203             if (len > along)
4204                 len = along;
4205             if (checksum) {
4206                 while (len-- > 0) {
4207                     Copy(s, &afloat, 1, float);
4208                     s += sizeof(float);
4209                     cdouble += afloat;
4210                 }
4211             }
4212             else {
4213                 EXTEND(SP, len);
4214                 EXTEND_MORTAL(len);
4215                 while (len-- > 0) {
4216                     Copy(s, &afloat, 1, float);
4217                     s += sizeof(float);
4218                     sv = NEWSV(47, 0);
4219                     sv_setnv(sv, (NV)afloat);
4220                     PUSHs(sv_2mortal(sv));
4221                 }
4222             }
4223             break;
4224         case 'd':
4225         case 'D':
4226             along = (strend - s) / sizeof(double);
4227             if (len > along)
4228                 len = along;
4229             if (checksum) {
4230                 while (len-- > 0) {
4231                     Copy(s, &adouble, 1, double);
4232                     s += sizeof(double);
4233                     cdouble += adouble;
4234                 }
4235             }
4236             else {
4237                 EXTEND(SP, len);
4238                 EXTEND_MORTAL(len);
4239                 while (len-- > 0) {
4240                     Copy(s, &adouble, 1, double);
4241                     s += sizeof(double);
4242                     sv = NEWSV(48, 0);
4243                     sv_setnv(sv, (NV)adouble);
4244                     PUSHs(sv_2mortal(sv));
4245                 }
4246             }
4247             break;
4248         case 'u':
4249             /* MKS:
4250              * Initialise the decode mapping.  By using a table driven
4251              * algorithm, the code will be character-set independent
4252              * (and just as fast as doing character arithmetic)
4253              */
4254             if (PL_uudmap['M'] == 0) {
4255                 int i;
4256
4257                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4258                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4259                 /*
4260                  * Because ' ' and '`' map to the same value,
4261                  * we need to decode them both the same.
4262                  */
4263                 PL_uudmap[' '] = 0;
4264             }
4265
4266             along = (strend - s) * 3 / 4;
4267             sv = NEWSV(42, along);
4268             if (along)
4269                 SvPOK_on(sv);
4270             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4271                 I32 a, b, c, d;
4272                 char hunk[4];
4273
4274                 hunk[3] = '\0';
4275                 len = PL_uudmap[*(U8*)s++] & 077;
4276                 while (len > 0) {
4277                     if (s < strend && ISUUCHAR(*s))
4278                         a = PL_uudmap[*(U8*)s++] & 077;
4279                     else
4280                         a = 0;
4281                     if (s < strend && ISUUCHAR(*s))
4282                         b = PL_uudmap[*(U8*)s++] & 077;
4283                     else
4284                         b = 0;
4285                     if (s < strend && ISUUCHAR(*s))
4286                         c = PL_uudmap[*(U8*)s++] & 077;
4287                     else
4288                         c = 0;
4289                     if (s < strend && ISUUCHAR(*s))
4290                         d = PL_uudmap[*(U8*)s++] & 077;
4291                     else
4292                         d = 0;
4293                     hunk[0] = (a << 2) | (b >> 4);
4294                     hunk[1] = (b << 4) | (c >> 2);
4295                     hunk[2] = (c << 6) | d;
4296                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4297                     len -= 3;
4298                 }
4299                 if (*s == '\n')
4300                     s++;
4301                 else if (s[1] == '\n')          /* possible checksum byte */
4302                     s += 2;
4303             }
4304             XPUSHs(sv_2mortal(sv));
4305             break;
4306         }
4307         if (checksum) {
4308             sv = NEWSV(42, 0);
4309             if (strchr("fFdD", datumtype) ||
4310               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4311                 NV trouble;
4312
4313                 adouble = 1.0;
4314                 while (checksum >= 16) {
4315                     checksum -= 16;
4316                     adouble *= 65536.0;
4317                 }
4318                 while (checksum >= 4) {
4319                     checksum -= 4;
4320                     adouble *= 16.0;
4321                 }
4322                 while (checksum--)
4323                     adouble *= 2.0;
4324                 along = (1 << checksum) - 1;
4325                 while (cdouble < 0.0)
4326                     cdouble += adouble;
4327                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4328                 sv_setnv(sv, cdouble);
4329             }
4330             else {
4331                 if (checksum < 32) {
4332                     aulong = (1 << checksum) - 1;
4333                     culong &= aulong;
4334                 }
4335                 sv_setuv(sv, (UV)culong);
4336             }
4337             XPUSHs(sv_2mortal(sv));
4338             checksum = 0;
4339         }
4340     }
4341     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4342         PUSHs(&PL_sv_undef);
4343     RETURN;
4344 }
4345
4346 STATIC void
4347 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4348 {
4349     char hunk[5];
4350
4351     *hunk = PL_uuemap[len];
4352     sv_catpvn(sv, hunk, 1);
4353     hunk[4] = '\0';
4354     while (len > 2) {
4355         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4356         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4357         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4358         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4359         sv_catpvn(sv, hunk, 4);
4360         s += 3;
4361         len -= 3;
4362     }
4363     if (len > 0) {
4364         char r = (len > 1 ? s[1] : '\0');
4365         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4366         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4367         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4368         hunk[3] = PL_uuemap[0];
4369         sv_catpvn(sv, hunk, 4);
4370     }
4371     sv_catpvn(sv, "\n", 1);
4372 }
4373
4374 STATIC SV *
4375 S_is_an_int(pTHX_ char *s, STRLEN l)
4376 {
4377   STRLEN         n_a;
4378   SV             *result = newSVpvn(s, l);
4379   char           *result_c = SvPV(result, n_a); /* convenience */
4380   char           *out = result_c;
4381   bool            skip = 1;
4382   bool            ignore = 0;
4383
4384   while (*s) {
4385     switch (*s) {
4386     case ' ':
4387       break;
4388     case '+':
4389       if (!skip) {
4390         SvREFCNT_dec(result);
4391         return (NULL);
4392       }
4393       break;
4394     case '0':
4395     case '1':
4396     case '2':
4397     case '3':
4398     case '4':
4399     case '5':
4400     case '6':
4401     case '7':
4402     case '8':
4403     case '9':
4404       skip = 0;
4405       if (!ignore) {
4406         *(out++) = *s;
4407       }
4408       break;
4409     case '.':
4410       ignore = 1;
4411       break;
4412     default:
4413       SvREFCNT_dec(result);
4414       return (NULL);
4415     }
4416     s++;
4417   }
4418   *(out++) = '\0';
4419   SvCUR_set(result, out - result_c);
4420   return (result);
4421 }
4422
4423 /* pnum must be '\0' terminated */
4424 STATIC int
4425 S_div128(pTHX_ SV *pnum, bool *done)
4426 {
4427   STRLEN          len;
4428   char           *s = SvPV(pnum, len);
4429   int             m = 0;
4430   int             r = 0;
4431   char           *t = s;
4432
4433   *done = 1;
4434   while (*t) {
4435     int             i;
4436
4437     i = m * 10 + (*t - '0');
4438     m = i & 0x7F;
4439     r = (i >> 7);               /* r < 10 */
4440     if (r) {
4441       *done = 0;
4442     }
4443     *(t++) = '0' + r;
4444   }
4445   *(t++) = '\0';
4446   SvCUR_set(pnum, (STRLEN) (t - s));
4447   return (m);
4448 }
4449
4450
4451 PP(pp_pack)
4452 {
4453     djSP; dMARK; dORIGMARK; dTARGET;
4454     register SV *cat = TARG;
4455     register I32 items;
4456     STRLEN fromlen;
4457     register char *pat = SvPVx(*++MARK, fromlen);
4458     char *patcopy;
4459     register char *patend = pat + fromlen;
4460     register I32 len;
4461     I32 datumtype;
4462     SV *fromstr;
4463     /*SUPPRESS 442*/
4464     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4465     static char *space10 = "          ";
4466
4467     /* These must not be in registers: */
4468     char achar;
4469     I16 ashort;
4470     int aint;
4471     unsigned int auint;
4472     I32 along;
4473     U32 aulong;
4474 #ifdef HAS_QUAD
4475     Quad_t aquad;
4476     Uquad_t auquad;
4477 #endif
4478     char *aptr;
4479     float afloat;
4480     double adouble;
4481     int commas = 0;
4482 #ifdef PERL_NATINT_PACK
4483     int natint;         /* native integer */
4484 #endif
4485
4486     items = SP - MARK;
4487     MARK++;
4488     sv_setpvn(cat, "", 0);
4489     patcopy = pat;
4490     while (pat < patend) {
4491         SV *lengthcode = Nullsv;
4492 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4493         datumtype = *pat++ & 0xFF;
4494 #ifdef PERL_NATINT_PACK
4495         natint = 0;
4496 #endif
4497         if (isSPACE(datumtype)) {
4498             patcopy++;
4499             continue;
4500         }
4501         if (datumtype == 'U' && pat == patcopy+1)
4502             SvUTF8_on(cat);
4503         if (datumtype == '#') {
4504             while (pat < patend && *pat != '\n')
4505                 pat++;
4506             continue;
4507         }
4508         if (*pat == '!') {
4509             char *natstr = "sSiIlL";
4510
4511             if (strchr(natstr, datumtype)) {
4512 #ifdef PERL_NATINT_PACK
4513                 natint = 1;
4514 #endif
4515                 pat++;
4516             }
4517             else
4518                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4519         }
4520         if (*pat == '*') {
4521             len = strchr("@Xxu", datumtype) ? 0 : items;
4522             pat++;
4523         }
4524         else if (isDIGIT(*pat)) {
4525             len = *pat++ - '0';
4526             while (isDIGIT(*pat)) {
4527                 len = (len * 10) + (*pat++ - '0');
4528                 if (len < 0)
4529                     DIE(aTHX_ "Repeat count in pack overflows");
4530             }
4531         }
4532         else
4533             len = 1;
4534         if (*pat == '/') {
4535             ++pat;
4536             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4537                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4538             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4539                                                    ? *MARK : &PL_sv_no)
4540                                             + (*pat == 'Z' ? 1 : 0)));
4541         }
4542         switch(datumtype) {
4543         default:
4544             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4545         case ',': /* grandfather in commas but with a warning */
4546             if (commas++ == 0 && ckWARN(WARN_PACK))
4547                 Perl_warner(aTHX_ WARN_PACK,
4548                             "Invalid type in pack: '%c'", (int)datumtype);
4549             break;
4550         case '%':
4551             DIE(aTHX_ "%% may only be used in unpack");
4552         case '@':
4553             len -= SvCUR(cat);
4554             if (len > 0)
4555                 goto grow;
4556             len = -len;
4557             if (len > 0)
4558                 goto shrink;
4559             break;
4560         case 'X':
4561           shrink:
4562             if (SvCUR(cat) < len)
4563                 DIE(aTHX_ "X outside of string");
4564             SvCUR(cat) -= len;
4565             *SvEND(cat) = '\0';
4566             break;
4567         case 'x':
4568           grow:
4569             while (len >= 10) {
4570                 sv_catpvn(cat, null10, 10);
4571                 len -= 10;
4572             }
4573             sv_catpvn(cat, null10, len);
4574             break;
4575         case 'A':
4576         case 'Z':
4577         case 'a':
4578             fromstr = NEXTFROM;
4579             aptr = SvPV(fromstr, fromlen);
4580             if (pat[-1] == '*') {
4581                 len = fromlen;
4582                 if (datumtype == 'Z')
4583                     ++len;
4584             }
4585             if (fromlen >= len) {
4586                 sv_catpvn(cat, aptr, len);
4587                 if (datumtype == 'Z')
4588                     *(SvEND(cat)-1) = '\0';
4589             }
4590             else {
4591                 sv_catpvn(cat, aptr, fromlen);
4592                 len -= fromlen;
4593                 if (datumtype == 'A') {
4594                     while (len >= 10) {
4595                         sv_catpvn(cat, space10, 10);
4596                         len -= 10;
4597                     }
4598                     sv_catpvn(cat, space10, len);
4599                 }
4600                 else {
4601                     while (len >= 10) {
4602                         sv_catpvn(cat, null10, 10);
4603                         len -= 10;
4604                     }
4605                     sv_catpvn(cat, null10, len);
4606                 }
4607             }
4608             break;
4609         case 'B':
4610         case 'b':
4611             {
4612                 register char *str;
4613                 I32 saveitems;
4614
4615                 fromstr = NEXTFROM;
4616                 saveitems = items;
4617                 str = SvPV(fromstr, fromlen);
4618                 if (pat[-1] == '*')
4619                     len = fromlen;
4620                 aint = SvCUR(cat);
4621                 SvCUR(cat) += (len+7)/8;
4622                 SvGROW(cat, SvCUR(cat) + 1);
4623                 aptr = SvPVX(cat) + aint;
4624                 if (len > fromlen)
4625                     len = fromlen;
4626                 aint = len;
4627                 items = 0;
4628                 if (datumtype == 'B') {
4629                     for (len = 0; len++ < aint;) {
4630                         items |= *str++ & 1;
4631                         if (len & 7)
4632                             items <<= 1;
4633                         else {
4634                             *aptr++ = items & 0xff;
4635                             items = 0;
4636                         }
4637                     }
4638                 }
4639                 else {
4640                     for (len = 0; len++ < aint;) {
4641                         if (*str++ & 1)
4642                             items |= 128;
4643                         if (len & 7)
4644                             items >>= 1;
4645                         else {
4646                             *aptr++ = items & 0xff;
4647                             items = 0;
4648                         }
4649                     }
4650                 }
4651                 if (aint & 7) {
4652                     if (datumtype == 'B')
4653                         items <<= 7 - (aint & 7);
4654                     else
4655                         items >>= 7 - (aint & 7);
4656                     *aptr++ = items & 0xff;
4657                 }
4658                 str = SvPVX(cat) + SvCUR(cat);
4659                 while (aptr <= str)
4660                     *aptr++ = '\0';
4661
4662                 items = saveitems;
4663             }
4664             break;
4665         case 'H':
4666         case 'h':
4667             {
4668                 register char *str;
4669                 I32 saveitems;
4670
4671                 fromstr = NEXTFROM;
4672                 saveitems = items;
4673                 str = SvPV(fromstr, fromlen);
4674                 if (pat[-1] == '*')
4675                     len = fromlen;
4676                 aint = SvCUR(cat);
4677                 SvCUR(cat) += (len+1)/2;
4678                 SvGROW(cat, SvCUR(cat) + 1);
4679                 aptr = SvPVX(cat) + aint;
4680                 if (len > fromlen)
4681                     len = fromlen;
4682                 aint = len;
4683                 items = 0;
4684                 if (datumtype == 'H') {
4685                     for (len = 0; len++ < aint;) {
4686                         if (isALPHA(*str))
4687                             items |= ((*str++ & 15) + 9) & 15;
4688                         else
4689                             items |= *str++ & 15;
4690                         if (len & 1)
4691                             items <<= 4;
4692                         else {
4693                             *aptr++ = items & 0xff;
4694                             items = 0;
4695                         }
4696                     }
4697                 }
4698                 else {
4699                     for (len = 0; len++ < aint;) {
4700                         if (isALPHA(*str))
4701                             items |= (((*str++ & 15) + 9) & 15) << 4;
4702                         else
4703                             items |= (*str++ & 15) << 4;
4704                         if (len & 1)
4705                             items >>= 4;
4706                         else {
4707                             *aptr++ = items & 0xff;
4708                             items = 0;
4709                         }
4710                     }
4711                 }
4712                 if (aint & 1)
4713                     *aptr++ = items & 0xff;
4714                 str = SvPVX(cat) + SvCUR(cat);
4715                 while (aptr <= str)
4716                     *aptr++ = '\0';
4717
4718                 items = saveitems;
4719             }
4720             break;
4721         case 'C':
4722         case 'c':
4723             while (len-- > 0) {
4724                 fromstr = NEXTFROM;
4725                 aint = SvIV(fromstr);
4726                 achar = aint;
4727                 sv_catpvn(cat, &achar, sizeof(char));
4728             }
4729             break;
4730         case 'U':
4731             while (len-- > 0) {
4732                 fromstr = NEXTFROM;
4733                 auint = SvUV(fromstr);
4734                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4735                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4736                                - SvPVX(cat));
4737             }
4738             *SvEND(cat) = '\0';
4739             break;
4740         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4741         case 'f':
4742         case 'F':
4743             while (len-- > 0) {
4744                 fromstr = NEXTFROM;
4745                 afloat = (float)SvNV(fromstr);
4746                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4747             }
4748             break;
4749         case 'd':
4750         case 'D':
4751             while (len-- > 0) {
4752                 fromstr = NEXTFROM;
4753                 adouble = (double)SvNV(fromstr);
4754                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4755             }
4756             break;
4757         case 'n':
4758             while (len-- > 0) {
4759                 fromstr = NEXTFROM;
4760                 ashort = (I16)SvIV(fromstr);
4761 #ifdef HAS_HTONS
4762                 ashort = PerlSock_htons(ashort);
4763 #endif
4764                 CAT16(cat, &ashort);
4765             }
4766             break;
4767         case 'v':
4768             while (len-- > 0) {
4769                 fromstr = NEXTFROM;
4770                 ashort = (I16)SvIV(fromstr);
4771 #ifdef HAS_HTOVS
4772                 ashort = htovs(ashort);
4773 #endif
4774                 CAT16(cat, &ashort);
4775             }
4776             break;
4777         case 'S':
4778 #if SHORTSIZE != SIZE16
4779             if (natint) {
4780                 unsigned short aushort;
4781
4782                 while (len-- > 0) {
4783                     fromstr = NEXTFROM;
4784                     aushort = SvUV(fromstr);
4785                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4786                 }
4787             }
4788             else
4789 #endif
4790             {
4791                 U16 aushort;
4792
4793                 while (len-- > 0) {
4794                     fromstr = NEXTFROM;
4795                     aushort = (U16)SvUV(fromstr);
4796                     CAT16(cat, &aushort);
4797                 }
4798
4799             }
4800             break;
4801         case 's':
4802 #if SHORTSIZE != SIZE16
4803             if (natint) {
4804                 short ashort;
4805
4806                 while (len-- > 0) {
4807                     fromstr = NEXTFROM;
4808                     ashort = SvIV(fromstr);
4809                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4810                 }
4811             }
4812             else
4813 #endif
4814             {
4815                 while (len-- > 0) {
4816                     fromstr = NEXTFROM;
4817                     ashort = (I16)SvIV(fromstr);
4818                     CAT16(cat, &ashort);
4819                 }
4820             }
4821             break;
4822         case 'I':
4823             while (len-- > 0) {
4824                 fromstr = NEXTFROM;
4825                 auint = SvUV(fromstr);
4826                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4827             }
4828             break;
4829         case 'w':
4830             while (len-- > 0) {
4831                 fromstr = NEXTFROM;
4832                 adouble = Perl_floor(SvNV(fromstr));
4833
4834                 if (adouble < 0)
4835                     DIE(aTHX_ "Cannot compress negative numbers");
4836
4837                 if (
4838 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4839                     adouble <= 0xffffffff
4840 #else
4841 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
4842                     adouble <= UV_MAX_cxux
4843 #   else
4844                     adouble <= UV_MAX
4845 #   endif
4846 #endif
4847                     )
4848                 {
4849                     char   buf[1 + sizeof(UV)];
4850                     char  *in = buf + sizeof(buf);
4851                     UV     auv = U_V(adouble);
4852
4853                     do {
4854                         *--in = (auv & 0x7f) | 0x80;
4855                         auv >>= 7;
4856                     } while (auv);
4857                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4858                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4859                 }
4860                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4861                     char           *from, *result, *in;
4862                     SV             *norm;
4863                     STRLEN          len;
4864                     bool            done;
4865
4866                     /* Copy string and check for compliance */
4867                     from = SvPV(fromstr, len);
4868                     if ((norm = is_an_int(from, len)) == NULL)
4869                         DIE(aTHX_ "can compress only unsigned integer");
4870
4871                     New('w', result, len, char);
4872                     in = result + len;
4873                     done = FALSE;
4874                     while (!done)
4875                         *--in = div128(norm, &done) | 0x80;
4876                     result[len - 1] &= 0x7F; /* clear continue bit */
4877                     sv_catpvn(cat, in, (result + len) - in);
4878                     Safefree(result);
4879                     SvREFCNT_dec(norm); /* free norm */
4880                 }
4881                 else if (SvNOKp(fromstr)) {
4882                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4883                     char  *in = buf + sizeof(buf);
4884
4885                     do {
4886                         double next = floor(adouble / 128);
4887                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4888                         if (in <= buf)  /* this cannot happen ;-) */
4889                             DIE(aTHX_ "Cannot compress integer");
4890                         in--;
4891                         adouble = next;
4892                     } while (adouble > 0);
4893                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4894                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4895                 }
4896                 else
4897                     DIE(aTHX_ "Cannot compress non integer");
4898             }
4899             break;
4900         case 'i':
4901             while (len-- > 0) {
4902                 fromstr = NEXTFROM;
4903                 aint = SvIV(fromstr);
4904                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4905             }
4906             break;
4907         case 'N':
4908             while (len-- > 0) {
4909                 fromstr = NEXTFROM;
4910                 aulong = SvUV(fromstr);
4911 #ifdef HAS_HTONL
4912                 aulong = PerlSock_htonl(aulong);
4913 #endif
4914                 CAT32(cat, &aulong);
4915             }
4916             break;
4917         case 'V':
4918             while (len-- > 0) {
4919                 fromstr = NEXTFROM;
4920                 aulong = SvUV(fromstr);
4921 #ifdef HAS_HTOVL
4922                 aulong = htovl(aulong);
4923 #endif
4924                 CAT32(cat, &aulong);
4925             }
4926             break;
4927         case 'L':
4928 #if LONGSIZE != SIZE32
4929             if (natint) {
4930                 unsigned long aulong;
4931
4932                 while (len-- > 0) {
4933                     fromstr = NEXTFROM;
4934                     aulong = SvUV(fromstr);
4935                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4936                 }
4937             }
4938             else
4939 #endif
4940             {
4941                 while (len-- > 0) {
4942                     fromstr = NEXTFROM;
4943                     aulong = SvUV(fromstr);
4944                     CAT32(cat, &aulong);
4945                 }
4946             }
4947             break;
4948         case 'l':
4949 #if LONGSIZE != SIZE32
4950             if (natint) {
4951                 long along;
4952
4953                 while (len-- > 0) {
4954                     fromstr = NEXTFROM;
4955                     along = SvIV(fromstr);
4956                     sv_catpvn(cat, (char *)&along, sizeof(long));
4957                 }
4958             }
4959             else
4960 #endif
4961             {
4962                 while (len-- > 0) {
4963                     fromstr = NEXTFROM;
4964                     along = SvIV(fromstr);
4965                     CAT32(cat, &along);
4966                 }
4967             }
4968             break;
4969 #ifdef HAS_QUAD
4970         case 'Q':
4971             while (len-- > 0) {
4972                 fromstr = NEXTFROM;
4973                 auquad = (Uquad_t)SvUV(fromstr);
4974                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4975             }
4976             break;
4977         case 'q':
4978             while (len-- > 0) {
4979                 fromstr = NEXTFROM;
4980                 aquad = (Quad_t)SvIV(fromstr);
4981                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4982             }
4983             break;
4984 #endif
4985         case 'P':
4986             len = 1;            /* assume SV is correct length */
4987             /* FALL THROUGH */
4988         case 'p':
4989             while (len-- > 0) {
4990                 fromstr = NEXTFROM;
4991                 if (fromstr == &PL_sv_undef)
4992                     aptr = NULL;
4993                 else {
4994                     STRLEN n_a;
4995                     /* XXX better yet, could spirit away the string to
4996                      * a safe spot and hang on to it until the result
4997                      * of pack() (and all copies of the result) are
4998                      * gone.
4999                      */
5000                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5001                                                 || (SvPADTMP(fromstr)
5002                                                     && !SvREADONLY(fromstr))))
5003                     {
5004                         Perl_warner(aTHX_ WARN_PACK,
5005                                 "Attempt to pack pointer to temporary value");
5006                     }
5007                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5008                         aptr = SvPV(fromstr,n_a);
5009                     else
5010                         aptr = SvPV_force(fromstr,n_a);
5011                 }
5012                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5013             }
5014             break;
5015         case 'u':
5016             fromstr = NEXTFROM;
5017             aptr = SvPV(fromstr, fromlen);
5018             SvGROW(cat, fromlen * 4 / 3);
5019             if (len <= 1)
5020                 len = 45;
5021             else
5022                 len = len / 3 * 3;
5023             while (fromlen > 0) {
5024                 I32 todo;
5025
5026                 if (fromlen > len)
5027                     todo = len;
5028                 else
5029                     todo = fromlen;
5030                 doencodes(cat, aptr, todo);
5031                 fromlen -= todo;
5032                 aptr += todo;
5033             }
5034             break;
5035         }
5036     }
5037     SvSETMAGIC(cat);
5038     SP = ORIGMARK;
5039     PUSHs(cat);
5040     RETURN;
5041 }
5042 #undef NEXTFROM
5043
5044
5045 PP(pp_split)
5046 {
5047     djSP; dTARG;
5048     AV *ary;
5049     register IV limit = POPi;                   /* note, negative is forever */
5050     SV *sv = POPs;
5051     bool doutf8 = DO_UTF8(sv);
5052     STRLEN len;
5053     register char *s = SvPV(sv, len);
5054     char *strend = s + len;
5055     register PMOP *pm;
5056     register REGEXP *rx;
5057     register SV *dstr;
5058     register char *m;
5059     I32 iters = 0;
5060     I32 maxiters = (strend - s) + 10;
5061     I32 i;
5062     char *orig;
5063     I32 origlimit = limit;
5064     I32 realarray = 0;
5065     I32 base;
5066     AV *oldstack = PL_curstack;
5067     I32 gimme = GIMME_V;
5068     I32 oldsave = PL_savestack_ix;
5069     I32 make_mortal = 1;
5070     MAGIC *mg = (MAGIC *) NULL;
5071
5072 #ifdef DEBUGGING
5073     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5074 #else
5075     pm = (PMOP*)POPs;
5076 #endif
5077     if (!pm || !s)
5078         DIE(aTHX_ "panic: do_split");
5079     rx = pm->op_pmregexp;
5080
5081     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5082              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5083
5084     if (pm->op_pmreplroot) {
5085 #ifdef USE_ITHREADS
5086         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5087 #else
5088         ary = GvAVn((GV*)pm->op_pmreplroot);
5089 #endif
5090     }
5091     else if (gimme != G_ARRAY)
5092 #ifdef USE_THREADS
5093         ary = (AV*)PL_curpad[0];
5094 #else
5095         ary = GvAVn(PL_defgv);
5096 #endif /* USE_THREADS */
5097     else
5098         ary = Nullav;
5099     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5100         realarray = 1;
5101         PUTBACK;
5102         av_extend(ary,0);
5103         av_clear(ary);
5104         SPAGAIN;
5105         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5106             PUSHMARK(SP);
5107             XPUSHs(SvTIED_obj((SV*)ary, mg));
5108         }
5109         else {
5110             if (!AvREAL(ary)) {
5111                 AvREAL_on(ary);
5112                 AvREIFY_off(ary);
5113                 for (i = AvFILLp(ary); i >= 0; i--)
5114                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5115             }
5116             /* temporarily switch stacks */
5117             SWITCHSTACK(PL_curstack, ary);
5118             make_mortal = 0;
5119         }
5120     }
5121     base = SP - PL_stack_base;
5122     orig = s;
5123     if (pm->op_pmflags & PMf_SKIPWHITE) {
5124         if (pm->op_pmflags & PMf_LOCALE) {
5125             while (isSPACE_LC(*s))
5126                 s++;
5127         }
5128         else {
5129             while (isSPACE(*s))
5130                 s++;
5131         }
5132     }
5133     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5134         SAVEINT(PL_multiline);
5135         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5136     }
5137
5138     if (!limit)
5139         limit = maxiters + 2;
5140     if (pm->op_pmflags & PMf_WHITE) {
5141         while (--limit) {
5142             m = s;
5143             while (m < strend &&
5144                    !((pm->op_pmflags & PMf_LOCALE)
5145                      ? isSPACE_LC(*m) : isSPACE(*m)))
5146                 ++m;
5147             if (m >= strend)
5148                 break;
5149
5150             dstr = NEWSV(30, m-s);
5151             sv_setpvn(dstr, s, m-s);
5152             if (make_mortal)
5153                 sv_2mortal(dstr);
5154             if (doutf8)
5155                 (void)SvUTF8_on(dstr);
5156             XPUSHs(dstr);
5157
5158             s = m + 1;
5159             while (s < strend &&
5160                    ((pm->op_pmflags & PMf_LOCALE)
5161                     ? isSPACE_LC(*s) : isSPACE(*s)))
5162                 ++s;
5163         }
5164     }
5165     else if (strEQ("^", rx->precomp)) {
5166         while (--limit) {
5167             /*SUPPRESS 530*/
5168             for (m = s; m < strend && *m != '\n'; m++) ;
5169             m++;
5170             if (m >= strend)
5171                 break;
5172             dstr = NEWSV(30, m-s);
5173             sv_setpvn(dstr, s, m-s);
5174             if (make_mortal)
5175                 sv_2mortal(dstr);
5176             if (doutf8)
5177                 (void)SvUTF8_on(dstr);
5178             XPUSHs(dstr);
5179             s = m;
5180         }
5181     }
5182     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5183              && (rx->reganch & ROPT_CHECK_ALL)
5184              && !(rx->reganch & ROPT_ANCH)) {
5185         int tail = (rx->reganch & RE_INTUIT_TAIL);
5186         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5187
5188         len = rx->minlen;
5189         if (len == 1 && !tail) {
5190             STRLEN n_a;
5191             char c = *SvPV(csv, n_a);
5192             while (--limit) {
5193                 /*SUPPRESS 530*/
5194                 for (m = s; m < strend && *m != c; m++) ;
5195                 if (m >= strend)
5196                     break;
5197                 dstr = NEWSV(30, m-s);
5198                 sv_setpvn(dstr, s, m-s);
5199                 if (make_mortal)
5200                     sv_2mortal(dstr);
5201                 if (doutf8)
5202                     (void)SvUTF8_on(dstr);
5203                 XPUSHs(dstr);
5204                 /* The rx->minlen is in characters but we want to step
5205                  * s ahead by bytes. */
5206                 s = m + (doutf8 ? SvCUR(csv) : len);
5207             }
5208         }
5209         else {
5210 #ifndef lint
5211             while (s < strend && --limit &&
5212               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5213                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5214 #endif
5215             {
5216                 dstr = NEWSV(31, m-s);
5217                 sv_setpvn(dstr, s, m-s);
5218                 if (make_mortal)
5219                     sv_2mortal(dstr);
5220                 if (doutf8)
5221                     (void)SvUTF8_on(dstr);
5222                 XPUSHs(dstr);
5223                 /* The rx->minlen is in characters but we want to step
5224                  * s ahead by bytes. */
5225                 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5226             }
5227         }
5228     }
5229     else {
5230         maxiters += (strend - s) * rx->nparens;
5231         while (s < strend && --limit
5232 /*             && (!rx->check_substr
5233                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5234                                                  0, NULL))))
5235 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5236                               1 /* minend */, sv, NULL, 0))
5237         {
5238             TAINT_IF(RX_MATCH_TAINTED(rx));
5239             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5240                 m = s;
5241                 s = orig;
5242                 orig = rx->subbeg;
5243                 s = orig + (m - s);
5244                 strend = s + (strend - m);
5245             }
5246             m = rx->startp[0] + orig;
5247             dstr = NEWSV(32, m-s);
5248             sv_setpvn(dstr, s, m-s);
5249             if (make_mortal)
5250                 sv_2mortal(dstr);
5251             if (doutf8)
5252                 (void)SvUTF8_on(dstr);
5253             XPUSHs(dstr);
5254             if (rx->nparens) {
5255                 for (i = 1; i <= rx->nparens; i++) {
5256                     s = rx->startp[i] + orig;
5257                     m = rx->endp[i] + orig;
5258                     if (m && s) {
5259                         dstr = NEWSV(33, m-s);
5260                         sv_setpvn(dstr, s, m-s);
5261                     }
5262                     else
5263                         dstr = NEWSV(33, 0);
5264                     if (make_mortal)
5265                         sv_2mortal(dstr);
5266                     if (doutf8)
5267                         (void)SvUTF8_on(dstr);
5268                     XPUSHs(dstr);
5269                 }
5270             }
5271             s = rx->endp[0] + orig;
5272         }
5273     }
5274
5275     LEAVE_SCOPE(oldsave);
5276     iters = (SP - PL_stack_base) - base;
5277     if (iters > maxiters)
5278         DIE(aTHX_ "Split loop");
5279
5280     /* keep field after final delim? */
5281     if (s < strend || (iters && origlimit)) {
5282         STRLEN l = strend - s;
5283         dstr = NEWSV(34, l);
5284         sv_setpvn(dstr, s, l);
5285         if (make_mortal)
5286             sv_2mortal(dstr);
5287         if (doutf8)
5288             (void)SvUTF8_on(dstr);
5289         XPUSHs(dstr);
5290         iters++;
5291     }
5292     else if (!origlimit) {
5293         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5294             iters--, SP--;
5295     }
5296
5297     if (realarray) {
5298         if (!mg) {
5299             SWITCHSTACK(ary, oldstack);
5300             if (SvSMAGICAL(ary)) {
5301                 PUTBACK;
5302                 mg_set((SV*)ary);
5303                 SPAGAIN;
5304             }
5305             if (gimme == G_ARRAY) {
5306                 EXTEND(SP, iters);
5307                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5308                 SP += iters;
5309                 RETURN;
5310             }
5311         }
5312         else {
5313             PUTBACK;
5314             ENTER;
5315             call_method("PUSH",G_SCALAR|G_DISCARD);
5316             LEAVE;
5317             SPAGAIN;
5318             if (gimme == G_ARRAY) {
5319                 /* EXTEND should not be needed - we just popped them */
5320                 EXTEND(SP, iters);
5321                 for (i=0; i < iters; i++) {
5322                     SV **svp = av_fetch(ary, i, FALSE);
5323                     PUSHs((svp) ? *svp : &PL_sv_undef);
5324                 }
5325                 RETURN;
5326             }
5327         }
5328     }
5329     else {
5330         if (gimme == G_ARRAY)
5331             RETURN;
5332     }
5333     if (iters || !pm->op_pmreplroot) {
5334         GETTARGET;
5335         PUSHi(iters);
5336         RETURN;
5337     }
5338     RETPUSHUNDEF;
5339 }
5340
5341 #ifdef USE_THREADS
5342 void
5343 Perl_unlock_condpair(pTHX_ void *svv)
5344 {
5345     dTHR;
5346     MAGIC *mg = mg_find((SV*)svv, 'm');
5347
5348     if (!mg)
5349         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5350     MUTEX_LOCK(MgMUTEXP(mg));
5351     if (MgOWNER(mg) != thr)
5352         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5353     MgOWNER(mg) = 0;
5354     COND_SIGNAL(MgOWNERCONDP(mg));
5355     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5356                           PTR2UV(thr), PTR2UV(svv));)
5357     MUTEX_UNLOCK(MgMUTEXP(mg));
5358 }
5359 #endif /* USE_THREADS */
5360
5361 PP(pp_lock)
5362 {
5363     djSP;
5364     dTOPss;
5365     SV *retsv = sv;
5366 #ifdef USE_THREADS
5367     sv_lock(sv);
5368 #endif /* USE_THREADS */
5369     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5370         || SvTYPE(retsv) == SVt_PVCV) {
5371         retsv = refto(retsv);
5372     }
5373     SETs(retsv);
5374     RETURN;
5375 }
5376
5377 PP(pp_threadsv)
5378 {
5379 #ifdef USE_THREADS
5380     djSP;
5381     EXTEND(SP, 1);
5382     if (PL_op->op_private & OPpLVAL_INTRO)
5383         PUSHs(*save_threadsv(PL_op->op_targ));
5384     else
5385         PUSHs(THREADSV(PL_op->op_targ));
5386     RETURN;
5387 #else
5388     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5389 #endif /* USE_THREADS */
5390 }