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