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