pp.c

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