pp.c

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