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 = utf8n_to_uvchr(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 = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2156                   tmps += UTF8SKIP(tmps);
2157                   result = uvchr_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)utf8n_to_uvchr(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 utf8_curlen;
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     SV *repl_sv = NULL;
2702     SV *repl_sv_copy = NULL;
2703     char *repl = 0;
2704     STRLEN repl_len;
2705     int num_args = PL_op->op_private & 7;
2706     bool repl_is_utf8 = FALSE;
2707
2708     SvTAINTED_off(TARG);                        /* decontaminate */
2709     SvUTF8_off(TARG);                           /* decontaminate */
2710     if (num_args > 2) {
2711         if (num_args > 3) {
2712             repl_sv = POPs;
2713             repl = SvPV(repl_sv, repl_len);
2714             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2715         }
2716         len = POPi;
2717     }
2718     pos = POPi;
2719     sv = POPs;
2720     PUTBACK;
2721     if (repl_sv) {
2722         if (repl_is_utf8) {
2723             if (!DO_UTF8(sv))
2724                 sv_utf8_upgrade(sv);
2725         }
2726         else if (DO_UTF8(sv)) {
2727             repl_sv_copy = newSVsv(repl_sv);
2728             sv_utf8_upgrade(repl_sv_copy);
2729             repl = SvPV(repl_sv_copy, repl_len);
2730             repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2731         }
2732     }
2733     tmps = SvPV(sv, curlen);
2734     if (DO_UTF8(sv)) {
2735         utf8_curlen = sv_len_utf8(sv);
2736         if (utf8_curlen == curlen)
2737             utf8_curlen = 0;
2738         else
2739             curlen = utf8_curlen;
2740     }
2741     else
2742         utf8_curlen = 0;
2743
2744     if (pos >= arybase) {
2745         pos -= arybase;
2746         rem = curlen-pos;
2747         fail = rem;
2748         if (num_args > 2) {
2749             if (len < 0) {
2750                 rem += len;
2751                 if (rem < 0)
2752                     rem = 0;
2753             }
2754             else if (rem > len)
2755                      rem = len;
2756         }
2757     }
2758     else {
2759         pos += curlen;
2760         if (num_args < 3)
2761             rem = curlen;
2762         else if (len >= 0) {
2763             rem = pos+len;
2764             if (rem > (I32)curlen)
2765                 rem = curlen;
2766         }
2767         else {
2768             rem = curlen+len;
2769             if (rem < pos)
2770                 rem = pos;
2771         }
2772         if (pos < 0)
2773             pos = 0;
2774         fail = rem;
2775         rem -= pos;
2776     }
2777     if (fail < 0) {
2778         if (lvalue || repl)
2779             Perl_croak(aTHX_ "substr outside of string");
2780         if (ckWARN(WARN_SUBSTR))
2781             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2782         RETPUSHUNDEF;
2783     }
2784     else {
2785         I32 upos = pos;
2786         I32 urem = rem;
2787         if (utf8_curlen)
2788             sv_pos_u2b(sv, &pos, &rem);
2789         tmps += pos;
2790         sv_setpvn(TARG, tmps, rem);
2791         if (utf8_curlen)
2792             SvUTF8_on(TARG);
2793         if (repl) {
2794             sv_insert(sv, pos, rem, repl, repl_len);
2795             if (repl_is_utf8)
2796                 SvUTF8_on(sv);
2797             if (repl_sv_copy)
2798                 SvREFCNT_dec(repl_sv_copy);
2799         }
2800         else if (lvalue) {              /* it's an lvalue! */
2801             if (!SvGMAGICAL(sv)) {
2802                 if (SvROK(sv)) {
2803                     STRLEN n_a;
2804                     SvPV_force(sv,n_a);
2805                     if (ckWARN(WARN_SUBSTR))
2806                         Perl_warner(aTHX_ WARN_SUBSTR,
2807                                 "Attempt to use reference as lvalue in substr");
2808                 }
2809                 if (SvOK(sv))           /* is it defined ? */
2810                     (void)SvPOK_only_UTF8(sv);
2811                 else
2812                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2813             }
2814
2815             if (SvTYPE(TARG) < SVt_PVLV) {
2816                 sv_upgrade(TARG, SVt_PVLV);
2817                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2818             }
2819
2820             LvTYPE(TARG) = 'x';
2821             if (LvTARG(TARG) != sv) {
2822                 if (LvTARG(TARG))
2823                     SvREFCNT_dec(LvTARG(TARG));
2824                 LvTARG(TARG) = SvREFCNT_inc(sv);
2825             }
2826             LvTARGOFF(TARG) = upos;
2827             LvTARGLEN(TARG) = urem;
2828         }
2829     }
2830     SPAGAIN;
2831     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2832     RETURN;
2833 }
2834
2835 PP(pp_vec)
2836 {
2837     dSP; dTARGET;
2838     register IV size   = POPi;
2839     register IV offset = POPi;
2840     register SV *src = POPs;
2841     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2842
2843     SvTAINTED_off(TARG);                /* decontaminate */
2844     if (lvalue) {                       /* it's an lvalue! */
2845         if (SvTYPE(TARG) < SVt_PVLV) {
2846             sv_upgrade(TARG, SVt_PVLV);
2847             sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2848         }
2849         LvTYPE(TARG) = 'v';
2850         if (LvTARG(TARG) != src) {
2851             if (LvTARG(TARG))
2852                 SvREFCNT_dec(LvTARG(TARG));
2853             LvTARG(TARG) = SvREFCNT_inc(src);
2854         }
2855         LvTARGOFF(TARG) = offset;
2856         LvTARGLEN(TARG) = size;
2857     }
2858
2859     sv_setuv(TARG, do_vecget(src, offset, size));
2860     PUSHs(TARG);
2861     RETURN;
2862 }
2863
2864 PP(pp_index)
2865 {
2866     dSP; dTARGET;
2867     SV *big;
2868     SV *little;
2869     I32 offset;
2870     I32 retval;
2871     char *tmps;
2872     char *tmps2;
2873     STRLEN biglen;
2874     I32 arybase = PL_curcop->cop_arybase;
2875
2876     if (MAXARG < 3)
2877         offset = 0;
2878     else
2879         offset = POPi - arybase;
2880     little = POPs;
2881     big = POPs;
2882     tmps = SvPV(big, biglen);
2883     if (offset > 0 && DO_UTF8(big))
2884         sv_pos_u2b(big, &offset, 0);
2885     if (offset < 0)
2886         offset = 0;
2887     else if (offset > biglen)
2888         offset = biglen;
2889     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2890       (unsigned char*)tmps + biglen, little, 0)))
2891         retval = -1;
2892     else
2893         retval = tmps2 - tmps;
2894     if (retval > 0 && DO_UTF8(big))
2895         sv_pos_b2u(big, &retval);
2896     PUSHi(retval + arybase);
2897     RETURN;
2898 }
2899
2900 PP(pp_rindex)
2901 {
2902     dSP; dTARGET;
2903     SV *big;
2904     SV *little;
2905     STRLEN blen;
2906     STRLEN llen;
2907     I32 offset;
2908     I32 retval;
2909     char *tmps;
2910     char *tmps2;
2911     I32 arybase = PL_curcop->cop_arybase;
2912
2913     if (MAXARG >= 3)
2914         offset = POPi;
2915     little = POPs;
2916     big = POPs;
2917     tmps2 = SvPV(little, llen);
2918     tmps = SvPV(big, blen);
2919     if (MAXARG < 3)
2920         offset = blen;
2921     else {
2922         if (offset > 0 && DO_UTF8(big))
2923             sv_pos_u2b(big, &offset, 0);
2924         offset = offset - arybase + llen;
2925     }
2926     if (offset < 0)
2927         offset = 0;
2928     else if (offset > blen)
2929         offset = blen;
2930     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2931                           tmps2, tmps2 + llen)))
2932         retval = -1;
2933     else
2934         retval = tmps2 - tmps;
2935     if (retval > 0 && DO_UTF8(big))
2936         sv_pos_b2u(big, &retval);
2937     PUSHi(retval + arybase);
2938     RETURN;
2939 }
2940
2941 PP(pp_sprintf)
2942 {
2943     dSP; dMARK; dORIGMARK; dTARGET;
2944     do_sprintf(TARG, SP-MARK, MARK+1);
2945     TAINT_IF(SvTAINTED(TARG));
2946     SP = ORIGMARK;
2947     PUSHTARG;
2948     RETURN;
2949 }
2950
2951 PP(pp_ord)
2952 {
2953     dSP; dTARGET;
2954     SV *argsv = POPs;
2955     STRLEN len;
2956     U8 *s = (U8*)SvPVx(argsv, len);
2957
2958     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2959     RETURN;
2960 }
2961
2962 PP(pp_chr)
2963 {
2964     dSP; dTARGET;
2965     char *tmps;
2966     UV value = POPu;
2967
2968     (void)SvUPGRADE(TARG,SVt_PV);
2969
2970     if (value > 255 && !IN_BYTE) {
2971         SvGROW(TARG, UNISKIP(value)+1);
2972         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2973         SvCUR_set(TARG, tmps - SvPVX(TARG));
2974         *tmps = '\0';
2975         (void)SvPOK_only(TARG);
2976         SvUTF8_on(TARG);
2977         XPUSHs(TARG);
2978         RETURN;
2979     }
2980
2981     SvGROW(TARG,2);
2982     SvCUR_set(TARG, 1);
2983     tmps = SvPVX(TARG);
2984     *tmps++ = value;
2985     *tmps = '\0';
2986     (void)SvPOK_only(TARG);
2987     XPUSHs(TARG);
2988     RETURN;
2989 }
2990
2991 PP(pp_crypt)
2992 {
2993     dSP; dTARGET; dPOPTOPssrl;
2994     STRLEN n_a;
2995 #ifdef HAS_CRYPT
2996     char *tmps = SvPV(left, n_a);
2997 #ifdef FCRYPT
2998     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2999 #else
3000     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3001 #endif
3002 #else
3003     DIE(aTHX_
3004       "The crypt() function is unimplemented due to excessive paranoia.");
3005 #endif
3006     SETs(TARG);
3007     RETURN;
3008 }
3009
3010 PP(pp_ucfirst)
3011 {
3012     dSP;
3013     SV *sv = TOPs;
3014     register U8 *s;
3015     STRLEN slen;
3016
3017     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3018         STRLEN ulen;
3019         U8 tmpbuf[UTF8_MAXLEN+1];
3020         U8 *tend;
3021         UV uv;
3022
3023         if (PL_op->op_private & OPpLOCALE) {
3024             TAINT;
3025             SvTAINTED_on(sv);
3026             uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3027         }
3028         else
3029             uv = toTITLE_utf8(s);
3030
3031         tend = uvchr_to_utf8(tmpbuf, uv);
3032
3033         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3034             dTARGET;
3035             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3036             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3037             SvUTF8_on(TARG);
3038             SETs(TARG);
3039         }
3040         else {
3041             s = (U8*)SvPV_force(sv, slen);
3042             Copy(tmpbuf, s, ulen, U8);
3043         }
3044     }
3045     else {
3046         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3047             dTARGET;
3048             SvUTF8_off(TARG);                           /* decontaminate */
3049             sv_setsv(TARG, sv);
3050             sv = TARG;
3051             SETs(sv);
3052         }
3053         s = (U8*)SvPV_force(sv, slen);
3054         if (*s) {
3055             if (PL_op->op_private & OPpLOCALE) {
3056                 TAINT;
3057                 SvTAINTED_on(sv);
3058                 *s = toUPPER_LC(*s);
3059             }
3060             else
3061                 *s = toUPPER(*s);
3062         }
3063     }
3064     if (SvSMAGICAL(sv))
3065         mg_set(sv);
3066     RETURN;
3067 }
3068
3069 PP(pp_lcfirst)
3070 {
3071     dSP;
3072     SV *sv = TOPs;
3073     register U8 *s;
3074     STRLEN slen;
3075
3076     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3077         STRLEN ulen;
3078         U8 tmpbuf[UTF8_MAXLEN+1];
3079         U8 *tend;
3080         UV uv;
3081
3082         if (PL_op->op_private & OPpLOCALE) {
3083             TAINT;
3084             SvTAINTED_on(sv);
3085             uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3086         }
3087         else
3088             uv = toLOWER_utf8(s);
3089
3090         tend = uvchr_to_utf8(tmpbuf, uv);
3091
3092         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3093             dTARGET;
3094             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3095             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3096             SvUTF8_on(TARG);
3097             SETs(TARG);
3098         }
3099         else {
3100             s = (U8*)SvPV_force(sv, slen);
3101             Copy(tmpbuf, s, ulen, U8);
3102         }
3103     }
3104     else {
3105         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3106             dTARGET;
3107             SvUTF8_off(TARG);                           /* decontaminate */
3108             sv_setsv(TARG, sv);
3109             sv = TARG;
3110             SETs(sv);
3111         }
3112         s = (U8*)SvPV_force(sv, slen);
3113         if (*s) {
3114             if (PL_op->op_private & OPpLOCALE) {
3115                 TAINT;
3116                 SvTAINTED_on(sv);
3117                 *s = toLOWER_LC(*s);
3118             }
3119             else
3120                 *s = toLOWER(*s);
3121         }
3122     }
3123     if (SvSMAGICAL(sv))
3124         mg_set(sv);
3125     RETURN;
3126 }
3127
3128 PP(pp_uc)
3129 {
3130     dSP;
3131     SV *sv = TOPs;
3132     register U8 *s;
3133     STRLEN len;
3134
3135     if (DO_UTF8(sv)) {
3136         dTARGET;
3137         STRLEN ulen;
3138         register U8 *d;
3139         U8 *send;
3140
3141         s = (U8*)SvPV(sv,len);
3142         if (!len) {
3143             SvUTF8_off(TARG);                           /* decontaminate */
3144             sv_setpvn(TARG, "", 0);
3145             SETs(TARG);
3146         }
3147         else {
3148             (void)SvUPGRADE(TARG, SVt_PV);
3149             SvGROW(TARG, (len * 2) + 1);
3150             (void)SvPOK_only(TARG);
3151             d = (U8*)SvPVX(TARG);
3152             send = s + len;
3153             if (PL_op->op_private & OPpLOCALE) {
3154                 TAINT;
3155                 SvTAINTED_on(TARG);
3156                 while (s < send) {
3157                     d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3158                     s += ulen;
3159                 }
3160             }
3161             else {
3162                 while (s < send) {
3163                     d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3164                     s += UTF8SKIP(s);
3165                 }
3166             }
3167             *d = '\0';
3168             SvUTF8_on(TARG);
3169             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3170             SETs(TARG);
3171         }
3172     }
3173     else {
3174         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3175             dTARGET;
3176             SvUTF8_off(TARG);                           /* decontaminate */
3177             sv_setsv(TARG, sv);
3178             sv = TARG;
3179             SETs(sv);
3180         }
3181         s = (U8*)SvPV_force(sv, len);
3182         if (len) {
3183             register U8 *send = s + len;
3184
3185             if (PL_op->op_private & OPpLOCALE) {
3186                 TAINT;
3187                 SvTAINTED_on(sv);
3188                 for (; s < send; s++)
3189                     *s = toUPPER_LC(*s);
3190             }
3191             else {
3192                 for (; s < send; s++)
3193                     *s = toUPPER(*s);
3194             }
3195         }
3196     }
3197     if (SvSMAGICAL(sv))
3198         mg_set(sv);
3199     RETURN;
3200 }
3201
3202 PP(pp_lc)
3203 {
3204     dSP;
3205     SV *sv = TOPs;
3206     register U8 *s;
3207     STRLEN len;
3208
3209     if (DO_UTF8(sv)) {
3210         dTARGET;
3211         STRLEN ulen;
3212         register U8 *d;
3213         U8 *send;
3214
3215         s = (U8*)SvPV(sv,len);
3216         if (!len) {
3217             SvUTF8_off(TARG);                           /* decontaminate */
3218             sv_setpvn(TARG, "", 0);
3219             SETs(TARG);
3220         }
3221         else {
3222             (void)SvUPGRADE(TARG, SVt_PV);
3223             SvGROW(TARG, (len * 2) + 1);
3224             (void)SvPOK_only(TARG);
3225             d = (U8*)SvPVX(TARG);
3226             send = s + len;
3227             if (PL_op->op_private & OPpLOCALE) {
3228                 TAINT;
3229                 SvTAINTED_on(TARG);
3230                 while (s < send) {
3231                     d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3232                     s += ulen;
3233                 }
3234             }
3235             else {
3236                 while (s < send) {
3237                     d = uvchr_to_utf8(d, toLOWER_utf8(s));
3238                     s += UTF8SKIP(s);
3239                 }
3240             }
3241             *d = '\0';
3242             SvUTF8_on(TARG);
3243             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3244             SETs(TARG);
3245         }
3246     }
3247     else {
3248         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3249             dTARGET;
3250             SvUTF8_off(TARG);                           /* decontaminate */
3251             sv_setsv(TARG, sv);
3252             sv = TARG;
3253             SETs(sv);
3254         }
3255
3256         s = (U8*)SvPV_force(sv, len);
3257         if (len) {
3258             register U8 *send = s + len;
3259
3260             if (PL_op->op_private & OPpLOCALE) {
3261                 TAINT;
3262                 SvTAINTED_on(sv);
3263                 for (; s < send; s++)
3264                     *s = toLOWER_LC(*s);
3265             }
3266             else {
3267                 for (; s < send; s++)
3268                     *s = toLOWER(*s);
3269             }
3270         }
3271     }
3272     if (SvSMAGICAL(sv))
3273         mg_set(sv);
3274     RETURN;
3275 }
3276
3277 PP(pp_quotemeta)
3278 {
3279     dSP; dTARGET;
3280     SV *sv = TOPs;
3281     STRLEN len;
3282     register char *s = SvPV(sv,len);
3283     register char *d;
3284
3285     SvUTF8_off(TARG);                           /* decontaminate */
3286     if (len) {
3287         (void)SvUPGRADE(TARG, SVt_PV);
3288         SvGROW(TARG, (len * 2) + 1);
3289         d = SvPVX(TARG);
3290         if (DO_UTF8(sv)) {
3291             while (len) {
3292                 if (UTF8_IS_CONTINUED(*s)) {
3293                     STRLEN ulen = UTF8SKIP(s);
3294                     if (ulen > len)
3295                         ulen = len;
3296                     len -= ulen;
3297                     while (ulen--)
3298                         *d++ = *s++;
3299                 }
3300                 else {
3301                     if (!isALNUM(*s))
3302                         *d++ = '\\';
3303                     *d++ = *s++;
3304                     len--;
3305                 }
3306             }
3307             SvUTF8_on(TARG);
3308         }
3309         else {
3310             while (len--) {
3311                 if (!isALNUM(*s))
3312                     *d++ = '\\';
3313                 *d++ = *s++;
3314             }
3315         }
3316         *d = '\0';
3317         SvCUR_set(TARG, d - SvPVX(TARG));
3318         (void)SvPOK_only_UTF8(TARG);
3319     }
3320     else
3321         sv_setpvn(TARG, s, len);
3322     SETs(TARG);
3323     if (SvSMAGICAL(TARG))
3324         mg_set(TARG);
3325     RETURN;
3326 }
3327
3328 /* Arrays. */
3329
3330 PP(pp_aslice)
3331 {
3332     dSP; dMARK; dORIGMARK;
3333     register SV** svp;
3334     register AV* av = (AV*)POPs;
3335     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3336     I32 arybase = PL_curcop->cop_arybase;
3337     I32 elem;
3338
3339     if (SvTYPE(av) == SVt_PVAV) {
3340         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3341             I32 max = -1;
3342             for (svp = MARK + 1; svp <= SP; svp++) {
3343                 elem = SvIVx(*svp);
3344                 if (elem > max)
3345                     max = elem;
3346             }
3347             if (max > AvMAX(av))
3348                 av_extend(av, max);
3349         }
3350         while (++MARK <= SP) {
3351             elem = SvIVx(*MARK);
3352
3353             if (elem > 0)
3354                 elem -= arybase;
3355             svp = av_fetch(av, elem, lval);
3356             if (lval) {
3357                 if (!svp || *svp == &PL_sv_undef)
3358                     DIE(aTHX_ PL_no_aelem, elem);
3359                 if (PL_op->op_private & OPpLVAL_INTRO)
3360                     save_aelem(av, elem, svp);
3361             }
3362             *MARK = svp ? *svp : &PL_sv_undef;
3363         }
3364     }
3365     if (GIMME != G_ARRAY) {
3366         MARK = ORIGMARK;
3367         *++MARK = *SP;
3368         SP = MARK;
3369     }
3370     RETURN;
3371 }
3372
3373 /* Associative arrays. */
3374
3375 PP(pp_each)
3376 {
3377     dSP;
3378     HV *hash = (HV*)POPs;
3379     HE *entry;
3380     I32 gimme = GIMME_V;
3381     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3382
3383     PUTBACK;
3384     /* might clobber stack_sp */
3385     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3386     SPAGAIN;
3387
3388     EXTEND(SP, 2);
3389     if (entry) {
3390         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3391         if (gimme == G_ARRAY) {
3392             SV *val;
3393             PUTBACK;
3394             /* might clobber stack_sp */
3395             val = realhv ?
3396                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3397             SPAGAIN;
3398             PUSHs(val);
3399         }
3400     }
3401     else if (gimme == G_SCALAR)
3402         RETPUSHUNDEF;
3403
3404     RETURN;
3405 }
3406
3407 PP(pp_values)
3408 {
3409     return do_kv();
3410 }
3411
3412 PP(pp_keys)
3413 {
3414     return do_kv();
3415 }
3416
3417 PP(pp_delete)
3418 {
3419     dSP;
3420     I32 gimme = GIMME_V;
3421     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3422     SV *sv;
3423     HV *hv;
3424
3425     if (PL_op->op_private & OPpSLICE) {
3426         dMARK; dORIGMARK;
3427         U32 hvtype;
3428         hv = (HV*)POPs;
3429         hvtype = SvTYPE(hv);
3430         if (hvtype == SVt_PVHV) {                       /* hash element */
3431             while (++MARK <= SP) {
3432                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3433                 *MARK = sv ? sv : &PL_sv_undef;
3434             }
3435         }
3436         else if (hvtype == SVt_PVAV) {
3437             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3438                 while (++MARK <= SP) {
3439                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3440                     *MARK = sv ? sv : &PL_sv_undef;
3441                 }
3442             }
3443             else {                                      /* pseudo-hash element */
3444                 while (++MARK <= SP) {
3445                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3446                     *MARK = sv ? sv : &PL_sv_undef;
3447                 }
3448             }
3449         }
3450         else
3451             DIE(aTHX_ "Not a HASH reference");
3452         if (discard)
3453             SP = ORIGMARK;
3454         else if (gimme == G_SCALAR) {
3455             MARK = ORIGMARK;
3456             *++MARK = *SP;
3457             SP = MARK;
3458         }
3459     }
3460     else {
3461         SV *keysv = POPs;
3462         hv = (HV*)POPs;
3463         if (SvTYPE(hv) == SVt_PVHV)
3464             sv = hv_delete_ent(hv, keysv, discard, 0);
3465         else if (SvTYPE(hv) == SVt_PVAV) {
3466             if (PL_op->op_flags & OPf_SPECIAL)
3467                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3468             else
3469                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3470         }
3471         else
3472             DIE(aTHX_ "Not a HASH reference");
3473         if (!sv)
3474             sv = &PL_sv_undef;
3475         if (!discard)
3476             PUSHs(sv);
3477     }
3478     RETURN;
3479 }
3480
3481 PP(pp_exists)
3482 {
3483     dSP;
3484     SV *tmpsv;
3485     HV *hv;
3486
3487     if (PL_op->op_private & OPpEXISTS_SUB) {
3488         GV *gv;
3489         CV *cv;
3490         SV *sv = POPs;
3491         cv = sv_2cv(sv, &hv, &gv, FALSE);
3492         if (cv)
3493             RETPUSHYES;
3494         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3495             RETPUSHYES;
3496         RETPUSHNO;
3497     }
3498     tmpsv = POPs;
3499     hv = (HV*)POPs;
3500     if (SvTYPE(hv) == SVt_PVHV) {
3501         if (hv_exists_ent(hv, tmpsv, 0))
3502             RETPUSHYES;
3503     }
3504     else if (SvTYPE(hv) == SVt_PVAV) {
3505         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3506             if (av_exists((AV*)hv, SvIV(tmpsv)))
3507                 RETPUSHYES;
3508         }
3509         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3510             RETPUSHYES;
3511     }
3512     else {
3513         DIE(aTHX_ "Not a HASH reference");
3514     }
3515     RETPUSHNO;
3516 }
3517
3518 PP(pp_hslice)
3519 {
3520     dSP; dMARK; dORIGMARK;
3521     register HV *hv = (HV*)POPs;
3522     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3523     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3524
3525     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3526         DIE(aTHX_ "Can't localize pseudo-hash element");
3527
3528     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3529         while (++MARK <= SP) {
3530             SV *keysv = *MARK;
3531             SV **svp;
3532             I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3533             if (realhv) {
3534                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3535                 svp = he ? &HeVAL(he) : 0;
3536             }
3537             else {
3538                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3539             }
3540             if (lval) {
3541                 if (!svp || *svp == &PL_sv_undef) {
3542                     STRLEN n_a;
3543                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3544                 }
3545                 if (PL_op->op_private & OPpLVAL_INTRO) {
3546                     if (preeminent)
3547                         save_helem(hv, keysv, svp);
3548                     else {
3549                         STRLEN keylen;
3550                         char *key = SvPV(keysv, keylen);
3551                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3552                     }
3553                 }
3554             }
3555             *MARK = svp ? *svp : &PL_sv_undef;
3556         }
3557     }
3558     if (GIMME != G_ARRAY) {
3559         MARK = ORIGMARK;
3560         *++MARK = *SP;
3561         SP = MARK;
3562     }
3563     RETURN;
3564 }
3565
3566 /* List operators. */
3567
3568 PP(pp_list)
3569 {
3570     dSP; dMARK;
3571     if (GIMME != G_ARRAY) {
3572         if (++MARK <= SP)
3573             *MARK = *SP;                /* unwanted list, return last item */
3574         else
3575             *MARK = &PL_sv_undef;
3576         SP = MARK;
3577     }
3578     RETURN;
3579 }
3580
3581 PP(pp_lslice)
3582 {
3583     dSP;
3584     SV **lastrelem = PL_stack_sp;
3585     SV **lastlelem = PL_stack_base + POPMARK;
3586     SV **firstlelem = PL_stack_base + POPMARK + 1;
3587     register SV **firstrelem = lastlelem + 1;
3588     I32 arybase = PL_curcop->cop_arybase;
3589     I32 lval = PL_op->op_flags & OPf_MOD;
3590     I32 is_something_there = lval;
3591
3592     register I32 max = lastrelem - lastlelem;
3593     register SV **lelem;
3594     register I32 ix;
3595
3596     if (GIMME != G_ARRAY) {
3597         ix = SvIVx(*lastlelem);
3598         if (ix < 0)
3599             ix += max;
3600         else
3601             ix -= arybase;
3602         if (ix < 0 || ix >= max)
3603             *firstlelem = &PL_sv_undef;
3604         else
3605             *firstlelem = firstrelem[ix];
3606         SP = firstlelem;
3607         RETURN;
3608     }
3609
3610     if (max == 0) {
3611         SP = firstlelem - 1;
3612         RETURN;
3613     }
3614
3615     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3616         ix = SvIVx(*lelem);
3617         if (ix < 0)
3618             ix += max;
3619         else
3620             ix -= arybase;
3621         if (ix < 0 || ix >= max)
3622             *lelem = &PL_sv_undef;
3623         else {
3624             is_something_there = TRUE;
3625             if (!(*lelem = firstrelem[ix]))
3626                 *lelem = &PL_sv_undef;
3627         }
3628     }
3629     if (is_something_there)
3630         SP = lastlelem;
3631     else
3632         SP = firstlelem - 1;
3633     RETURN;
3634 }
3635
3636 PP(pp_anonlist)
3637 {
3638     dSP; dMARK; dORIGMARK;
3639     I32 items = SP - MARK;
3640     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3641     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3642     XPUSHs(av);
3643     RETURN;
3644 }
3645
3646 PP(pp_anonhash)
3647 {
3648     dSP; dMARK; dORIGMARK;
3649     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3650
3651     while (MARK < SP) {
3652         SV* key = *++MARK;
3653         SV *val = NEWSV(46, 0);
3654         if (MARK < SP)
3655             sv_setsv(val, *++MARK);
3656         else if (ckWARN(WARN_MISC))
3657             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3658         (void)hv_store_ent(hv,key,val,0);
3659     }
3660     SP = ORIGMARK;
3661     XPUSHs((SV*)hv);
3662     RETURN;
3663 }
3664
3665 PP(pp_splice)
3666 {
3667     dSP; dMARK; dORIGMARK;
3668     register AV *ary = (AV*)*++MARK;
3669     register SV **src;
3670     register SV **dst;
3671     register I32 i;
3672     register I32 offset;
3673     register I32 length;
3674     I32 newlen;
3675     I32 after;
3676     I32 diff;
3677     SV **tmparyval = 0;
3678     MAGIC *mg;
3679
3680     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3681         *MARK-- = SvTIED_obj((SV*)ary, mg);
3682         PUSHMARK(MARK);
3683         PUTBACK;
3684         ENTER;
3685         call_method("SPLICE",GIMME_V);
3686         LEAVE;
3687         SPAGAIN;
3688         RETURN;
3689     }
3690
3691     SP++;
3692
3693     if (++MARK < SP) {
3694         offset = i = SvIVx(*MARK);
3695         if (offset < 0)
3696             offset += AvFILLp(ary) + 1;
3697         else
3698             offset -= PL_curcop->cop_arybase;
3699         if (offset < 0)
3700             DIE(aTHX_ PL_no_aelem, i);
3701         if (++MARK < SP) {
3702             length = SvIVx(*MARK++);
3703             if (length < 0) {
3704                 length += AvFILLp(ary) - offset + 1;
3705                 if (length < 0)
3706                     length = 0;
3707             }
3708         }
3709         else
3710             length = AvMAX(ary) + 1;            /* close enough to infinity */
3711     }
3712     else {
3713         offset = 0;
3714         length = AvMAX(ary) + 1;
3715     }
3716     if (offset > AvFILLp(ary) + 1)
3717         offset = AvFILLp(ary) + 1;
3718     after = AvFILLp(ary) + 1 - (offset + length);
3719     if (after < 0) {                            /* not that much array */
3720         length += after;                        /* offset+length now in array */
3721         after = 0;
3722         if (!AvALLOC(ary))
3723             av_extend(ary, 0);
3724     }
3725
3726     /* At this point, MARK .. SP-1 is our new LIST */
3727
3728     newlen = SP - MARK;
3729     diff = newlen - length;
3730     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3731         av_reify(ary);
3732
3733     if (diff < 0) {                             /* shrinking the area */
3734         if (newlen) {
3735             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3736             Copy(MARK, tmparyval, newlen, SV*);
3737         }
3738
3739         MARK = ORIGMARK + 1;
3740         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3741             MEXTEND(MARK, length);
3742             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3743             if (AvREAL(ary)) {
3744                 EXTEND_MORTAL(length);
3745                 for (i = length, dst = MARK; i; i--) {
3746                     sv_2mortal(*dst);   /* free them eventualy */
3747                     dst++;
3748                 }
3749             }
3750             MARK += length - 1;
3751         }
3752         else {
3753             *MARK = AvARRAY(ary)[offset+length-1];
3754             if (AvREAL(ary)) {
3755                 sv_2mortal(*MARK);
3756                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3757                     SvREFCNT_dec(*dst++);       /* free them now */
3758             }
3759         }
3760         AvFILLp(ary) += diff;
3761
3762         /* pull up or down? */
3763
3764         if (offset < after) {                   /* easier to pull up */
3765             if (offset) {                       /* esp. if nothing to pull */
3766                 src = &AvARRAY(ary)[offset-1];
3767                 dst = src - diff;               /* diff is negative */
3768                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3769                     *dst-- = *src--;
3770             }
3771             dst = AvARRAY(ary);
3772             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3773             AvMAX(ary) += diff;
3774         }
3775         else {
3776             if (after) {                        /* anything to pull down? */
3777                 src = AvARRAY(ary) + offset + length;
3778                 dst = src + diff;               /* diff is negative */
3779                 Move(src, dst, after, SV*);
3780             }
3781             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3782                                                 /* avoid later double free */
3783         }
3784         i = -diff;
3785         while (i)
3786             dst[--i] = &PL_sv_undef;
3787
3788         if (newlen) {
3789             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3790               newlen; newlen--) {
3791                 *dst = NEWSV(46, 0);
3792                 sv_setsv(*dst++, *src++);
3793             }
3794             Safefree(tmparyval);
3795         }
3796     }
3797     else {                                      /* no, expanding (or same) */
3798         if (length) {
3799             New(452, tmparyval, length, SV*);   /* so remember deletion */
3800             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3801         }
3802
3803         if (diff > 0) {                         /* expanding */
3804
3805             /* push up or down? */
3806
3807             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3808                 if (offset) {
3809                     src = AvARRAY(ary);
3810                     dst = src - diff;
3811                     Move(src, dst, offset, SV*);
3812                 }
3813                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3814                 AvMAX(ary) += diff;
3815                 AvFILLp(ary) += diff;
3816             }
3817             else {
3818                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3819                     av_extend(ary, AvFILLp(ary) + diff);
3820                 AvFILLp(ary) += diff;
3821
3822                 if (after) {
3823                     dst = AvARRAY(ary) + AvFILLp(ary);
3824                     src = dst - diff;
3825                     for (i = after; i; i--) {
3826                         *dst-- = *src--;
3827                     }
3828                 }
3829             }
3830         }
3831
3832         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3833             *dst = NEWSV(46, 0);
3834             sv_setsv(*dst++, *src++);
3835         }
3836         MARK = ORIGMARK + 1;
3837         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3838             if (length) {
3839                 Copy(tmparyval, MARK, length, SV*);
3840                 if (AvREAL(ary)) {
3841                     EXTEND_MORTAL(length);
3842                     for (i = length, dst = MARK; i; i--) {
3843                         sv_2mortal(*dst);       /* free them eventualy */
3844                         dst++;
3845                     }
3846                 }
3847                 Safefree(tmparyval);
3848             }
3849             MARK += length - 1;
3850         }
3851         else if (length--) {
3852             *MARK = tmparyval[length];
3853             if (AvREAL(ary)) {
3854                 sv_2mortal(*MARK);
3855                 while (length-- > 0)
3856                     SvREFCNT_dec(tmparyval[length]);
3857             }
3858             Safefree(tmparyval);
3859         }
3860         else
3861             *MARK = &PL_sv_undef;
3862     }
3863     SP = MARK;
3864     RETURN;
3865 }
3866
3867 PP(pp_push)
3868 {
3869     dSP; dMARK; dORIGMARK; dTARGET;
3870     register AV *ary = (AV*)*++MARK;
3871     register SV *sv = &PL_sv_undef;
3872     MAGIC *mg;
3873
3874     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3875         *MARK-- = SvTIED_obj((SV*)ary, mg);
3876         PUSHMARK(MARK);
3877         PUTBACK;
3878         ENTER;
3879         call_method("PUSH",G_SCALAR|G_DISCARD);
3880         LEAVE;
3881         SPAGAIN;
3882     }
3883     else {
3884         /* Why no pre-extend of ary here ? */
3885         for (++MARK; MARK <= SP; MARK++) {
3886             sv = NEWSV(51, 0);
3887             if (*MARK)
3888                 sv_setsv(sv, *MARK);
3889             av_push(ary, sv);
3890         }
3891     }
3892     SP = ORIGMARK;
3893     PUSHi( AvFILL(ary) + 1 );
3894     RETURN;
3895 }
3896
3897 PP(pp_pop)
3898 {
3899     dSP;
3900     AV *av = (AV*)POPs;
3901     SV *sv = av_pop(av);
3902     if (AvREAL(av))
3903         (void)sv_2mortal(sv);
3904     PUSHs(sv);
3905     RETURN;
3906 }
3907
3908 PP(pp_shift)
3909 {
3910     dSP;
3911     AV *av = (AV*)POPs;
3912     SV *sv = av_shift(av);
3913     EXTEND(SP, 1);
3914     if (!sv)
3915         RETPUSHUNDEF;
3916     if (AvREAL(av))
3917         (void)sv_2mortal(sv);
3918     PUSHs(sv);
3919     RETURN;
3920 }
3921
3922 PP(pp_unshift)
3923 {
3924     dSP; dMARK; dORIGMARK; dTARGET;
3925     register AV *ary = (AV*)*++MARK;
3926     register SV *sv;
3927     register I32 i = 0;
3928     MAGIC *mg;
3929
3930     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3931         *MARK-- = SvTIED_obj((SV*)ary, mg);
3932         PUSHMARK(MARK);
3933         PUTBACK;
3934         ENTER;
3935         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3936         LEAVE;
3937         SPAGAIN;
3938     }
3939     else {
3940         av_unshift(ary, SP - MARK);
3941         while (MARK < SP) {
3942             sv = NEWSV(27, 0);
3943             sv_setsv(sv, *++MARK);
3944             (void)av_store(ary, i++, sv);
3945         }
3946     }
3947     SP = ORIGMARK;
3948     PUSHi( AvFILL(ary) + 1 );
3949     RETURN;
3950 }
3951
3952 PP(pp_reverse)
3953 {
3954     dSP; dMARK;
3955     register SV *tmp;
3956     SV **oldsp = SP;
3957
3958     if (GIMME == G_ARRAY) {
3959         MARK++;
3960         while (MARK < SP) {
3961             tmp = *MARK;
3962             *MARK++ = *SP;
3963             *SP-- = tmp;
3964         }
3965         /* safe as long as stack cannot get extended in the above */
3966         SP = oldsp;
3967     }
3968     else {
3969         register char *up;
3970         register char *down;
3971         register I32 tmp;
3972         dTARGET;
3973         STRLEN len;
3974
3975         SvUTF8_off(TARG);                               /* decontaminate */
3976         if (SP - MARK > 1)
3977             do_join(TARG, &PL_sv_no, MARK, SP);
3978         else
3979             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3980         up = SvPV_force(TARG, len);
3981         if (len > 1) {
3982             if (DO_UTF8(TARG)) {        /* first reverse each character */
3983                 U8* s = (U8*)SvPVX(TARG);
3984                 U8* send = (U8*)(s + len);
3985                 while (s < send) {
3986                     if (UTF8_IS_INVARIANT(*s)) {
3987                         s++;
3988                         continue;
3989                     }
3990                     else {
3991                         if (!utf8_to_uvchr(s, 0))
3992                             break;
3993                         up = (char*)s;
3994                         s += UTF8SKIP(s);
3995                         down = (char*)(s - 1);
3996                         /* reverse this character */
3997                         while (down > up) {
3998                             tmp = *up;
3999                             *up++ = *down;
4000                             *down-- = tmp;
4001                         }
4002                     }
4003                 }
4004                 up = SvPVX(TARG);
4005             }
4006             down = SvPVX(TARG) + len - 1;
4007             while (down > up) {
4008                 tmp = *up;
4009                 *up++ = *down;
4010                 *down-- = tmp;
4011             }
4012             (void)SvPOK_only_UTF8(TARG);
4013         }
4014         SP = MARK + 1;
4015         SETTARG;
4016     }
4017     RETURN;
4018 }
4019
4020 STATIC SV *
4021 S_mul128(pTHX_ SV *sv, U8 m)
4022 {
4023   STRLEN          len;
4024   char           *s = SvPV(sv, len);
4025   char           *t;
4026   U32             i = 0;
4027
4028   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
4029     SV             *tmpNew = newSVpvn("0000000000", 10);
4030
4031     sv_catsv(tmpNew, sv);
4032     SvREFCNT_dec(sv);           /* free old sv */
4033     sv = tmpNew;
4034     s = SvPV(sv, len);
4035   }
4036   t = s + len - 1;
4037   while (!*t)                   /* trailing '\0'? */
4038     t--;
4039   while (t > s) {
4040     i = ((*t - '0') << 7) + m;
4041     *(t--) = '0' + (i % 10);
4042     m = i / 10;
4043   }
4044   return (sv);
4045 }
4046
4047 /* Explosives and implosives. */
4048
4049 #if 'I' == 73 && 'J' == 74
4050 /* On an ASCII/ISO kind of system */
4051 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
4052 #else
4053 /*
4054   Some other sort of character set - use memchr() so we don't match
4055   the null byte.
4056  */
4057 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4058 #endif
4059
4060
4061 PP(pp_unpack)
4062 {
4063     dSP;
4064     dPOPPOPssrl;
4065     I32 start_sp_offset = SP - PL_stack_base;
4066     I32 gimme = GIMME_V;
4067     SV *sv;
4068     STRLEN llen;
4069     STRLEN rlen;
4070     register char *pat = SvPV(left, llen);
4071 #ifdef PACKED_IS_OCTETS
4072     /* Packed side is assumed to be octets - so force downgrade if it
4073        has been UTF-8 encoded by accident
4074      */
4075     register char *s = SvPVbyte(right, rlen);
4076 #else
4077     register char *s = SvPV(right, rlen);
4078 #endif
4079     char *strend = s + rlen;
4080     char *strbeg = s;
4081     register char *patend = pat + llen;
4082     I32 datumtype;
4083     register I32 len;
4084     register I32 bits;
4085     register char *str;
4086
4087     /* These must not be in registers: */
4088     short ashort;
4089     int aint;
4090     long along;
4091 #ifdef HAS_QUAD
4092     Quad_t aquad;
4093 #endif
4094     U16 aushort;
4095     unsigned int auint;
4096     U32 aulong;
4097 #ifdef HAS_QUAD
4098     Uquad_t auquad;
4099 #endif
4100     char *aptr;
4101     float afloat;
4102     double adouble;
4103     I32 checksum = 0;
4104     register U32 culong;
4105     NV cdouble;
4106     int commas = 0;
4107     int star;
4108 #ifdef PERL_NATINT_PACK
4109     int natint;         /* native integer */
4110     int unatint;        /* unsigned native integer */
4111 #endif
4112
4113     if (gimme != G_ARRAY) {             /* arrange to do first one only */
4114         /*SUPPRESS 530*/
4115         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4116         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4117             patend++;
4118             while (isDIGIT(*patend) || *patend == '*')
4119                 patend++;
4120         }
4121         else
4122             patend++;
4123     }
4124     while (pat < patend) {
4125       reparse:
4126         datumtype = *pat++ & 0xFF;
4127 #ifdef PERL_NATINT_PACK
4128         natint = 0;
4129 #endif
4130         if (isSPACE(datumtype))
4131             continue;
4132         if (datumtype == '#') {
4133             while (pat < patend && *pat != '\n')
4134                 pat++;
4135             continue;
4136         }
4137         if (*pat == '!') {
4138             char *natstr = "sSiIlL";
4139
4140             if (strchr(natstr, datumtype)) {
4141 #ifdef PERL_NATINT_PACK
4142                 natint = 1;
4143 #endif
4144                 pat++;
4145             }
4146             else
4147                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4148         }
4149         star = 0;
4150         if (pat >= patend)
4151             len = 1;
4152         else if (*pat == '*') {
4153             len = strend - strbeg;      /* long enough */
4154             pat++;
4155             star = 1;
4156         }
4157         else if (isDIGIT(*pat)) {
4158             len = *pat++ - '0';
4159             while (isDIGIT(*pat)) {
4160                 len = (len * 10) + (*pat++ - '0');
4161                 if (len < 0)
4162                     DIE(aTHX_ "Repeat count in unpack overflows");
4163             }
4164         }
4165         else
4166             len = (datumtype != '@');
4167       redo_switch:
4168         switch(datumtype) {
4169         default:
4170             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4171         case ',': /* grandfather in commas but with a warning */
4172             if (commas++ == 0 && ckWARN(WARN_UNPACK))
4173                 Perl_warner(aTHX_ WARN_UNPACK,
4174                             "Invalid type in unpack: '%c'", (int)datumtype);
4175             break;
4176         case '%':
4177             if (len == 1 && pat[-1] != '1')
4178                 len = 16;
4179             checksum = len;
4180             culong = 0;
4181             cdouble = 0;
4182             if (pat < patend)
4183                 goto reparse;
4184             break;
4185         case '@':
4186             if (len > strend - strbeg)
4187                 DIE(aTHX_ "@ outside of string");
4188             s = strbeg + len;
4189             break;
4190         case 'X':
4191             if (len > s - strbeg)
4192                 DIE(aTHX_ "X outside of string");
4193             s -= len;
4194             break;
4195         case 'x':
4196             if (len > strend - s)
4197                 DIE(aTHX_ "x outside of string");
4198             s += len;
4199             break;
4200         case '/':
4201             if (start_sp_offset >= SP - PL_stack_base)
4202                 DIE(aTHX_ "/ must follow a numeric type");
4203             datumtype = *pat++;
4204             if (*pat == '*')
4205                 pat++;          /* ignore '*' for compatibility with pack */
4206             if (isDIGIT(*pat))
4207                 DIE(aTHX_ "/ cannot take a count" );
4208             len = POPi;
4209             star = 0;
4210             goto redo_switch;
4211         case 'A':
4212         case 'Z':
4213         case 'a':
4214             if (len > strend - s)
4215                 len = strend - s;
4216             if (checksum)
4217                 goto uchar_checksum;
4218             sv = NEWSV(35, len);
4219             sv_setpvn(sv, s, len);
4220             s += len;
4221             if (datumtype == 'A' || datumtype == 'Z') {
4222                 aptr = s;       /* borrow register */
4223                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4224                     s = SvPVX(sv);
4225                     while (*s)
4226                         s++;
4227                 }
4228                 else {          /* 'A' strips both nulls and spaces */
4229                     s = SvPVX(sv) + len - 1;
4230                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4231                         s--;
4232                     *++s = '\0';
4233                 }
4234                 SvCUR_set(sv, s - SvPVX(sv));
4235                 s = aptr;       /* unborrow register */
4236             }
4237             XPUSHs(sv_2mortal(sv));
4238             break;
4239         case 'B':
4240         case 'b':
4241             if (star || len > (strend - s) * 8)
4242                 len = (strend - s) * 8;
4243             if (checksum) {
4244                 if (!PL_bitcount) {
4245                     Newz(601, PL_bitcount, 256, char);
4246                     for (bits = 1; bits < 256; bits++) {
4247                         if (bits & 1)   PL_bitcount[bits]++;
4248                         if (bits & 2)   PL_bitcount[bits]++;
4249                         if (bits & 4)   PL_bitcount[bits]++;
4250                         if (bits & 8)   PL_bitcount[bits]++;
4251                         if (bits & 16)  PL_bitcount[bits]++;
4252                         if (bits & 32)  PL_bitcount[bits]++;
4253                         if (bits & 64)  PL_bitcount[bits]++;
4254                         if (bits & 128) PL_bitcount[bits]++;
4255                     }
4256                 }
4257                 while (len >= 8) {
4258                     culong += PL_bitcount[*(unsigned char*)s++];
4259                     len -= 8;
4260                 }
4261                 if (len) {
4262                     bits = *s;
4263                     if (datumtype == 'b') {
4264                         while (len-- > 0) {
4265                             if (bits & 1) culong++;
4266                             bits >>= 1;
4267                         }
4268                     }
4269                     else {
4270                         while (len-- > 0) {
4271                             if (bits & 128) culong++;
4272                             bits <<= 1;
4273                         }
4274                     }
4275                 }
4276                 break;
4277             }
4278             sv = NEWSV(35, len + 1);
4279             SvCUR_set(sv, len);
4280             SvPOK_on(sv);
4281             str = SvPVX(sv);
4282             if (datumtype == 'b') {
4283                 aint = len;
4284                 for (len = 0; len < aint; len++) {
4285                     if (len & 7)                /*SUPPRESS 595*/
4286                         bits >>= 1;
4287                     else
4288                         bits = *s++;
4289                     *str++ = '0' + (bits & 1);
4290                 }
4291             }
4292             else {
4293                 aint = len;
4294                 for (len = 0; len < aint; len++) {
4295                     if (len & 7)
4296                         bits <<= 1;
4297                     else
4298                         bits = *s++;
4299                     *str++ = '0' + ((bits & 128) != 0);
4300                 }
4301             }
4302             *str = '\0';
4303             XPUSHs(sv_2mortal(sv));
4304             break;
4305         case 'H':
4306         case 'h':
4307             if (star || len > (strend - s) * 2)
4308                 len = (strend - s) * 2;
4309             sv = NEWSV(35, len + 1);
4310             SvCUR_set(sv, len);
4311             SvPOK_on(sv);
4312             str = SvPVX(sv);
4313             if (datumtype == 'h') {
4314                 aint = len;
4315                 for (len = 0; len < aint; len++) {
4316                     if (len & 1)
4317                         bits >>= 4;
4318                     else
4319                         bits = *s++;
4320                     *str++ = PL_hexdigit[bits & 15];
4321                 }
4322             }
4323             else {
4324                 aint = len;
4325                 for (len = 0; len < aint; len++) {
4326                     if (len & 1)
4327                         bits <<= 4;
4328                     else
4329                         bits = *s++;
4330                     *str++ = PL_hexdigit[(bits >> 4) & 15];
4331                 }
4332             }
4333             *str = '\0';
4334             XPUSHs(sv_2mortal(sv));
4335             break;
4336         case 'c':
4337             if (len > strend - s)
4338                 len = strend - s;
4339             if (checksum) {
4340                 while (len-- > 0) {
4341                     aint = *s++;
4342                     if (aint >= 128)    /* fake up signed chars */
4343                         aint -= 256;
4344                     culong += aint;
4345                 }
4346             }
4347             else {
4348                 EXTEND(SP, len);
4349                 EXTEND_MORTAL(len);
4350                 while (len-- > 0) {
4351                     aint = *s++;
4352                     if (aint >= 128)    /* fake up signed chars */
4353                         aint -= 256;
4354                     sv = NEWSV(36, 0);
4355                     sv_setiv(sv, (IV)aint);
4356                     PUSHs(sv_2mortal(sv));
4357                 }
4358             }
4359             break;
4360         case 'C':
4361             if (len > strend - s)
4362                 len = strend - s;
4363             if (checksum) {
4364               uchar_checksum:
4365                 while (len-- > 0) {
4366                     auint = *s++ & 255;
4367                     culong += auint;
4368                 }
4369             }
4370             else {
4371                 EXTEND(SP, len);
4372                 EXTEND_MORTAL(len);
4373                 while (len-- > 0) {
4374                     auint = *s++ & 255;
4375                     sv = NEWSV(37, 0);
4376                     sv_setiv(sv, (IV)auint);
4377                     PUSHs(sv_2mortal(sv));
4378                 }
4379             }
4380             break;
4381         case 'U':
4382             if (len > strend - s)
4383                 len = strend - s;
4384             if (checksum) {
4385                 while (len-- > 0 && s < strend) {
4386                     STRLEN alen;
4387                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4388                     along = alen;
4389                     s += along;
4390                     if (checksum > 32)
4391                         cdouble += (NV)auint;
4392                     else
4393                         culong += auint;
4394                 }
4395             }
4396             else {
4397                 EXTEND(SP, len);
4398                 EXTEND_MORTAL(len);
4399                 while (len-- > 0 && s < strend) {
4400                     STRLEN alen;
4401                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4402                     along = alen;
4403                     s += along;
4404                     sv = NEWSV(37, 0);
4405                     sv_setuv(sv, (UV)auint);
4406                     PUSHs(sv_2mortal(sv));
4407                 }
4408             }
4409             break;
4410         case 's':
4411 #if SHORTSIZE == SIZE16
4412             along = (strend - s) / SIZE16;
4413 #else
4414             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4415 #endif
4416             if (len > along)
4417                 len = along;
4418             if (checksum) {
4419 #if SHORTSIZE != SIZE16
4420                 if (natint) {
4421                     short ashort;
4422                     while (len-- > 0) {
4423                         COPYNN(s, &ashort, sizeof(short));
4424                         s += sizeof(short);
4425                         culong += ashort;
4426
4427                     }
4428                 }
4429                 else
4430 #endif
4431                 {
4432                     while (len-- > 0) {
4433                         COPY16(s, &ashort);
4434 #if SHORTSIZE > SIZE16
4435                         if (ashort > 32767)
4436                           ashort -= 65536;
4437 #endif
4438                         s += SIZE16;
4439                         culong += ashort;
4440                     }
4441                 }
4442             }
4443             else {
4444                 EXTEND(SP, len);
4445                 EXTEND_MORTAL(len);
4446 #if SHORTSIZE != SIZE16
4447                 if (natint) {
4448                     short ashort;
4449                     while (len-- > 0) {
4450                         COPYNN(s, &ashort, sizeof(short));
4451                         s += sizeof(short);
4452                         sv = NEWSV(38, 0);
4453                         sv_setiv(sv, (IV)ashort);
4454                         PUSHs(sv_2mortal(sv));
4455                     }
4456                 }
4457                 else
4458 #endif
4459                 {
4460                     while (len-- > 0) {
4461                         COPY16(s, &ashort);
4462 #if SHORTSIZE > SIZE16
4463                         if (ashort > 32767)
4464                           ashort -= 65536;
4465 #endif
4466                         s += SIZE16;
4467                         sv = NEWSV(38, 0);
4468                         sv_setiv(sv, (IV)ashort);
4469                         PUSHs(sv_2mortal(sv));
4470                     }
4471                 }
4472             }
4473             break;
4474         case 'v':
4475         case 'n':
4476         case 'S':
4477 #if SHORTSIZE == SIZE16
4478             along = (strend - s) / SIZE16;
4479 #else
4480             unatint = natint && datumtype == 'S';
4481             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4482 #endif
4483             if (len > along)
4484                 len = along;
4485             if (checksum) {
4486 #if SHORTSIZE != SIZE16
4487                 if (unatint) {
4488                     unsigned short aushort;
4489                     while (len-- > 0) {
4490                         COPYNN(s, &aushort, sizeof(unsigned short));
4491                         s += sizeof(unsigned short);
4492                         culong += aushort;
4493                     }
4494                 }
4495                 else
4496 #endif
4497                 {
4498                     while (len-- > 0) {
4499                         COPY16(s, &aushort);
4500                         s += SIZE16;
4501 #ifdef HAS_NTOHS
4502                         if (datumtype == 'n')
4503                             aushort = PerlSock_ntohs(aushort);
4504 #endif
4505 #ifdef HAS_VTOHS
4506                         if (datumtype == 'v')
4507                             aushort = vtohs(aushort);
4508 #endif
4509                         culong += aushort;
4510                     }
4511                 }
4512             }
4513             else {
4514                 EXTEND(SP, len);
4515                 EXTEND_MORTAL(len);
4516 #if SHORTSIZE != SIZE16
4517                 if (unatint) {
4518                     unsigned short aushort;
4519                     while (len-- > 0) {
4520                         COPYNN(s, &aushort, sizeof(unsigned short));
4521                         s += sizeof(unsigned short);
4522                         sv = NEWSV(39, 0);
4523                         sv_setiv(sv, (UV)aushort);
4524                         PUSHs(sv_2mortal(sv));
4525                     }
4526                 }
4527                 else
4528 #endif
4529                 {
4530                     while (len-- > 0) {
4531                         COPY16(s, &aushort);
4532                         s += SIZE16;
4533                         sv = NEWSV(39, 0);
4534 #ifdef HAS_NTOHS
4535                         if (datumtype == 'n')
4536                             aushort = PerlSock_ntohs(aushort);
4537 #endif
4538 #ifdef HAS_VTOHS
4539                         if (datumtype == 'v')
4540                             aushort = vtohs(aushort);
4541 #endif
4542                         sv_setiv(sv, (UV)aushort);
4543                         PUSHs(sv_2mortal(sv));
4544                     }
4545                 }
4546             }
4547             break;
4548         case 'i':
4549             along = (strend - s) / sizeof(int);
4550             if (len > along)
4551                 len = along;
4552             if (checksum) {
4553                 while (len-- > 0) {
4554                     Copy(s, &aint, 1, int);
4555                     s += sizeof(int);
4556                     if (checksum > 32)
4557                         cdouble += (NV)aint;
4558                     else
4559                         culong += aint;
4560                 }
4561             }
4562             else {
4563                 EXTEND(SP, len);
4564                 EXTEND_MORTAL(len);
4565                 while (len-- > 0) {
4566                     Copy(s, &aint, 1, int);
4567                     s += sizeof(int);
4568                     sv = NEWSV(40, 0);
4569 #ifdef __osf__
4570                     /* Without the dummy below unpack("i", pack("i",-1))
4571                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4572                      * cc with optimization turned on.
4573                      *
4574                      * The bug was detected in
4575                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4576                      * with optimization (-O4) turned on.
4577                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4578                      * does not have this problem even with -O4.
4579                      *
4580                      * This bug was reported as DECC_BUGS 1431
4581                      * and tracked internally as GEM_BUGS 7775.
4582                      *
4583                      * The bug is fixed in
4584                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
4585                      * UNIX V4.0F support:   DEC C V5.9-006 or later
4586                      * UNIX V4.0E support:   DEC C V5.8-011 or later
4587                      * and also in DTK.
4588                      *
4589                      * See also few lines later for the same bug.
4590                      */
4591                     (aint) ?
4592                         sv_setiv(sv, (IV)aint) :
4593 #endif
4594                     sv_setiv(sv, (IV)aint);
4595                     PUSHs(sv_2mortal(sv));
4596                 }
4597             }
4598             break;
4599         case 'I':
4600             along = (strend - s) / sizeof(unsigned int);
4601             if (len > along)
4602                 len = along;
4603             if (checksum) {
4604                 while (len-- > 0) {
4605                     Copy(s, &auint, 1, unsigned int);
4606                     s += sizeof(unsigned int);
4607                     if (checksum > 32)
4608                         cdouble += (NV)auint;
4609                     else
4610                         culong += auint;
4611                 }
4612             }
4613             else {
4614                 EXTEND(SP, len);
4615                 EXTEND_MORTAL(len);
4616                 while (len-- > 0) {
4617                     Copy(s, &auint, 1, unsigned int);
4618                     s += sizeof(unsigned int);
4619                     sv = NEWSV(41, 0);
4620 #ifdef __osf__
4621                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4622                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4623                      * See details few lines earlier. */
4624                     (auint) ?
4625                         sv_setuv(sv, (UV)auint) :
4626 #endif
4627                     sv_setuv(sv, (UV)auint);
4628                     PUSHs(sv_2mortal(sv));
4629                 }
4630             }
4631             break;
4632         case 'l':
4633 #if LONGSIZE == SIZE32
4634             along = (strend - s) / SIZE32;
4635 #else
4636             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4637 #endif
4638             if (len > along)
4639                 len = along;
4640             if (checksum) {
4641 #if LONGSIZE != SIZE32
4642                 if (natint) {
4643                     while (len-- > 0) {
4644                         COPYNN(s, &along, sizeof(long));
4645                         s += sizeof(long);
4646                         if (checksum > 32)
4647                             cdouble += (NV)along;
4648                         else
4649                             culong += along;
4650                     }
4651                 }
4652                 else
4653 #endif
4654                 {
4655                     while (len-- > 0) {
4656 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4657                         I32 along;
4658 #endif
4659                         COPY32(s, &along);
4660 #if LONGSIZE > SIZE32
4661                         if (along > 2147483647)
4662                           along -= 4294967296;
4663 #endif
4664                         s += SIZE32;
4665                         if (checksum > 32)
4666                             cdouble += (NV)along;
4667                         else
4668                             culong += along;
4669                     }
4670                 }
4671             }
4672             else {
4673                 EXTEND(SP, len);
4674                 EXTEND_MORTAL(len);
4675 #if LONGSIZE != SIZE32
4676                 if (natint) {
4677                     while (len-- > 0) {
4678                         COPYNN(s, &along, sizeof(long));
4679                         s += sizeof(long);
4680                         sv = NEWSV(42, 0);
4681                         sv_setiv(sv, (IV)along);
4682                         PUSHs(sv_2mortal(sv));
4683                     }
4684                 }
4685                 else
4686 #endif
4687                 {
4688                     while (len-- > 0) {
4689 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4690                         I32 along;
4691 #endif
4692                         COPY32(s, &along);
4693 #if LONGSIZE > SIZE32
4694                         if (along > 2147483647)
4695                           along -= 4294967296;
4696 #endif
4697                         s += SIZE32;
4698                         sv = NEWSV(42, 0);
4699                         sv_setiv(sv, (IV)along);
4700                         PUSHs(sv_2mortal(sv));
4701                     }
4702                 }
4703             }
4704             break;
4705         case 'V':
4706         case 'N':
4707         case 'L':
4708 #if LONGSIZE == SIZE32
4709             along = (strend - s) / SIZE32;
4710 #else
4711             unatint = natint && datumtype == 'L';
4712             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4713 #endif
4714             if (len > along)
4715                 len = along;
4716             if (checksum) {
4717 #if LONGSIZE != SIZE32
4718                 if (unatint) {
4719                     unsigned long aulong;
4720                     while (len-- > 0) {
4721                         COPYNN(s, &aulong, sizeof(unsigned long));
4722                         s += sizeof(unsigned long);
4723                         if (checksum > 32)
4724                             cdouble += (NV)aulong;
4725                         else
4726                             culong += aulong;
4727                     }
4728                 }
4729                 else
4730 #endif
4731                 {
4732                     while (len-- > 0) {
4733                         COPY32(s, &aulong);
4734                         s += SIZE32;
4735 #ifdef HAS_NTOHL
4736                         if (datumtype == 'N')
4737                             aulong = PerlSock_ntohl(aulong);
4738 #endif
4739 #ifdef HAS_VTOHL
4740                         if (datumtype == 'V')
4741                             aulong = vtohl(aulong);
4742 #endif
4743                         if (checksum > 32)
4744                             cdouble += (NV)aulong;
4745                         else
4746                             culong += aulong;
4747                     }
4748                 }
4749             }
4750             else {
4751                 EXTEND(SP, len);
4752                 EXTEND_MORTAL(len);
4753 #if LONGSIZE != SIZE32
4754                 if (unatint) {
4755                     unsigned long aulong;
4756                     while (len-- > 0) {
4757                         COPYNN(s, &aulong, sizeof(unsigned long));
4758                         s += sizeof(unsigned long);
4759                         sv = NEWSV(43, 0);
4760                         sv_setuv(sv, (UV)aulong);
4761                         PUSHs(sv_2mortal(sv));
4762                     }
4763                 }
4764                 else
4765 #endif
4766                 {
4767                     while (len-- > 0) {
4768                         COPY32(s, &aulong);
4769                         s += SIZE32;
4770 #ifdef HAS_NTOHL
4771                         if (datumtype == 'N')
4772                             aulong = PerlSock_ntohl(aulong);
4773 #endif
4774 #ifdef HAS_VTOHL
4775                         if (datumtype == 'V')
4776                             aulong = vtohl(aulong);
4777 #endif
4778                         sv = NEWSV(43, 0);
4779                         sv_setuv(sv, (UV)aulong);
4780                         PUSHs(sv_2mortal(sv));
4781                     }
4782                 }
4783             }
4784             break;
4785         case 'p':
4786             along = (strend - s) / sizeof(char*);
4787             if (len > along)
4788                 len = along;
4789             EXTEND(SP, len);
4790             EXTEND_MORTAL(len);
4791             while (len-- > 0) {
4792                 if (sizeof(char*) > strend - s)
4793                     break;
4794                 else {
4795                     Copy(s, &aptr, 1, char*);
4796                     s += sizeof(char*);
4797                 }
4798                 sv = NEWSV(44, 0);
4799                 if (aptr)
4800                     sv_setpv(sv, aptr);
4801                 PUSHs(sv_2mortal(sv));
4802             }
4803             break;
4804         case 'w':
4805             EXTEND(SP, len);
4806             EXTEND_MORTAL(len);
4807             {
4808                 UV auv = 0;
4809                 U32 bytes = 0;
4810
4811                 while ((len > 0) && (s < strend)) {
4812                     auv = (auv << 7) | (*s & 0x7f);
4813                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4814                     if ((U8)(*s++) < 0x80) {
4815                         bytes = 0;
4816                         sv = NEWSV(40, 0);
4817                         sv_setuv(sv, auv);
4818                         PUSHs(sv_2mortal(sv));
4819                         len--;
4820                         auv = 0;
4821                     }
4822                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4823                         char *t;
4824                         STRLEN n_a;
4825
4826                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4827                         while (s < strend) {
4828                             sv = mul128(sv, *s & 0x7f);
4829                             if (!(*s++ & 0x80)) {
4830                                 bytes = 0;
4831                                 break;
4832                             }
4833                         }
4834                         t = SvPV(sv, n_a);
4835                         while (*t == '0')
4836                             t++;
4837                         sv_chop(sv, t);
4838                         PUSHs(sv_2mortal(sv));
4839                         len--;
4840                         auv = 0;
4841                     }
4842                 }
4843                 if ((s >= strend) && bytes)
4844                     DIE(aTHX_ "Unterminated compressed integer");
4845             }
4846             break;
4847         case 'P':
4848             EXTEND(SP, 1);
4849             if (sizeof(char*) > strend - s)
4850                 break;
4851             else {
4852                 Copy(s, &aptr, 1, char*);
4853                 s += sizeof(char*);
4854             }
4855             sv = NEWSV(44, 0);
4856             if (aptr)
4857                 sv_setpvn(sv, aptr, len);
4858             PUSHs(sv_2mortal(sv));
4859             break;
4860 #ifdef HAS_QUAD
4861         case 'q':
4862             along = (strend - s) / sizeof(Quad_t);
4863             if (len > along)
4864                 len = along;
4865             EXTEND(SP, len);
4866             EXTEND_MORTAL(len);
4867             while (len-- > 0) {
4868                 if (s + sizeof(Quad_t) > strend)
4869                     aquad = 0;
4870                 else {
4871                     Copy(s, &aquad, 1, Quad_t);
4872                     s += sizeof(Quad_t);
4873                 }
4874                 sv = NEWSV(42, 0);
4875                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4876                     sv_setiv(sv, (IV)aquad);
4877                 else
4878                     sv_setnv(sv, (NV)aquad);
4879                 PUSHs(sv_2mortal(sv));
4880             }
4881             break;
4882         case 'Q':
4883             along = (strend - s) / sizeof(Quad_t);
4884             if (len > along)
4885                 len = along;
4886             EXTEND(SP, len);
4887             EXTEND_MORTAL(len);
4888             while (len-- > 0) {
4889                 if (s + sizeof(Uquad_t) > strend)
4890                     auquad = 0;
4891                 else {
4892                     Copy(s, &auquad, 1, Uquad_t);
4893                     s += sizeof(Uquad_t);
4894                 }
4895                 sv = NEWSV(43, 0);
4896                 if (auquad <= UV_MAX)
4897                     sv_setuv(sv, (UV)auquad);
4898                 else
4899                     sv_setnv(sv, (NV)auquad);
4900                 PUSHs(sv_2mortal(sv));
4901             }
4902             break;
4903 #endif
4904         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4905         case 'f':
4906         case 'F':
4907             along = (strend - s) / sizeof(float);
4908             if (len > along)
4909                 len = along;
4910             if (checksum) {
4911                 while (len-- > 0) {
4912                     Copy(s, &afloat, 1, float);
4913                     s += sizeof(float);
4914                     cdouble += afloat;
4915                 }
4916             }
4917             else {
4918                 EXTEND(SP, len);
4919                 EXTEND_MORTAL(len);
4920                 while (len-- > 0) {
4921                     Copy(s, &afloat, 1, float);
4922                     s += sizeof(float);
4923                     sv = NEWSV(47, 0);
4924                     sv_setnv(sv, (NV)afloat);
4925                     PUSHs(sv_2mortal(sv));
4926                 }
4927             }
4928             break;
4929         case 'd':
4930         case 'D':
4931             along = (strend - s) / sizeof(double);
4932             if (len > along)
4933                 len = along;
4934             if (checksum) {
4935                 while (len-- > 0) {
4936                     Copy(s, &adouble, 1, double);
4937                     s += sizeof(double);
4938                     cdouble += adouble;
4939                 }
4940             }
4941             else {
4942                 EXTEND(SP, len);
4943                 EXTEND_MORTAL(len);
4944                 while (len-- > 0) {
4945                     Copy(s, &adouble, 1, double);
4946                     s += sizeof(double);
4947                     sv = NEWSV(48, 0);
4948                     sv_setnv(sv, (NV)adouble);
4949                     PUSHs(sv_2mortal(sv));
4950                 }
4951             }
4952             break;
4953         case 'u':
4954             /* MKS:
4955              * Initialise the decode mapping.  By using a table driven
4956              * algorithm, the code will be character-set independent
4957              * (and just as fast as doing character arithmetic)
4958              */
4959             if (PL_uudmap['M'] == 0) {
4960                 int i;
4961
4962                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4963                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4964                 /*
4965                  * Because ' ' and '`' map to the same value,
4966                  * we need to decode them both the same.
4967                  */
4968                 PL_uudmap[' '] = 0;
4969             }
4970
4971             along = (strend - s) * 3 / 4;
4972             sv = NEWSV(42, along);
4973             if (along)
4974                 SvPOK_on(sv);
4975             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4976                 I32 a, b, c, d;
4977                 char hunk[4];
4978
4979                 hunk[3] = '\0';
4980                 len = PL_uudmap[*(U8*)s++] & 077;
4981                 while (len > 0) {
4982                     if (s < strend && ISUUCHAR(*s))
4983                         a = PL_uudmap[*(U8*)s++] & 077;
4984                     else
4985                         a = 0;
4986                     if (s < strend && ISUUCHAR(*s))
4987                         b = PL_uudmap[*(U8*)s++] & 077;
4988                     else
4989                         b = 0;
4990                     if (s < strend && ISUUCHAR(*s))
4991                         c = PL_uudmap[*(U8*)s++] & 077;
4992                     else
4993                         c = 0;
4994                     if (s < strend && ISUUCHAR(*s))
4995                         d = PL_uudmap[*(U8*)s++] & 077;
4996                     else
4997                         d = 0;
4998                     hunk[0] = (a << 2) | (b >> 4);
4999                     hunk[1] = (b << 4) | (c >> 2);
5000                     hunk[2] = (c << 6) | d;
5001                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5002                     len -= 3;
5003                 }
5004                 if (*s == '\n')
5005                     s++;
5006                 else if (s[1] == '\n')          /* possible checksum byte */
5007                     s += 2;
5008             }
5009             XPUSHs(sv_2mortal(sv));
5010             break;
5011         }
5012         if (checksum) {
5013             sv = NEWSV(42, 0);
5014             if (strchr("fFdD", datumtype) ||
5015               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5016                 NV trouble;
5017
5018                 adouble = 1.0;
5019                 while (checksum >= 16) {
5020                     checksum -= 16;
5021                     adouble *= 65536.0;
5022                 }
5023                 while (checksum >= 4) {
5024                     checksum -= 4;
5025                     adouble *= 16.0;
5026                 }
5027                 while (checksum--)
5028                     adouble *= 2.0;
5029                 along = (1 << checksum) - 1;
5030                 while (cdouble < 0.0)
5031                     cdouble += adouble;
5032                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5033                 sv_setnv(sv, cdouble);
5034             }
5035             else {
5036                 if (checksum < 32) {
5037                     aulong = (1 << checksum) - 1;
5038                     culong &= aulong;
5039                 }
5040                 sv_setuv(sv, (UV)culong);
5041             }
5042             XPUSHs(sv_2mortal(sv));
5043             checksum = 0;
5044         }
5045     }
5046     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5047         PUSHs(&PL_sv_undef);
5048     RETURN;
5049 }
5050
5051 STATIC void
5052 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5053 {
5054     char hunk[5];
5055
5056     *hunk = PL_uuemap[len];
5057     sv_catpvn(sv, hunk, 1);
5058     hunk[4] = '\0';
5059     while (len > 2) {
5060         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5061         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5062         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5063         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5064         sv_catpvn(sv, hunk, 4);
5065         s += 3;
5066         len -= 3;
5067     }
5068     if (len > 0) {
5069         char r = (len > 1 ? s[1] : '\0');
5070         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5071         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5072         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5073         hunk[3] = PL_uuemap[0];
5074         sv_catpvn(sv, hunk, 4);
5075     }
5076     sv_catpvn(sv, "\n", 1);
5077 }
5078
5079 STATIC SV *
5080 S_is_an_int(pTHX_ char *s, STRLEN l)
5081 {
5082   STRLEN         n_a;
5083   SV             *result = newSVpvn(s, l);
5084   char           *result_c = SvPV(result, n_a); /* convenience */
5085   char           *out = result_c;
5086   bool            skip = 1;
5087   bool            ignore = 0;
5088
5089   while (*s) {
5090     switch (*s) {
5091     case ' ':
5092       break;
5093     case '+':
5094       if (!skip) {
5095         SvREFCNT_dec(result);
5096         return (NULL);
5097       }
5098       break;
5099     case '0':
5100     case '1':
5101     case '2':
5102     case '3':
5103     case '4':
5104     case '5':
5105     case '6':
5106     case '7':
5107     case '8':
5108     case '9':
5109       skip = 0;
5110       if (!ignore) {
5111         *(out++) = *s;
5112       }
5113       break;
5114     case '.':
5115       ignore = 1;
5116       break;
5117     default:
5118       SvREFCNT_dec(result);
5119       return (NULL);
5120     }
5121     s++;
5122   }
5123   *(out++) = '\0';
5124   SvCUR_set(result, out - result_c);
5125   return (result);
5126 }
5127
5128 /* pnum must be '\0' terminated */
5129 STATIC int
5130 S_div128(pTHX_ SV *pnum, bool *done)
5131 {
5132   STRLEN          len;
5133   char           *s = SvPV(pnum, len);
5134   int             m = 0;
5135   int             r = 0;
5136   char           *t = s;
5137
5138   *done = 1;
5139   while (*t) {
5140     int             i;
5141
5142     i = m * 10 + (*t - '0');
5143     m = i & 0x7F;
5144     r = (i >> 7);               /* r < 10 */
5145     if (r) {
5146       *done = 0;
5147     }
5148     *(t++) = '0' + r;
5149   }
5150   *(t++) = '\0';
5151   SvCUR_set(pnum, (STRLEN) (t - s));
5152   return (m);
5153 }
5154
5155
5156 PP(pp_pack)
5157 {
5158     dSP; dMARK; dORIGMARK; dTARGET;
5159     register SV *cat = TARG;
5160     register I32 items;
5161     STRLEN fromlen;
5162     register char *pat = SvPVx(*++MARK, fromlen);
5163     char *patcopy;
5164     register char *patend = pat + fromlen;
5165     register I32 len;
5166     I32 datumtype;
5167     SV *fromstr;
5168     /*SUPPRESS 442*/
5169     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5170     static char *space10 = "          ";
5171
5172     /* These must not be in registers: */
5173     char achar;
5174     I16 ashort;
5175     int aint;
5176     unsigned int auint;
5177     I32 along;
5178     U32 aulong;
5179 #ifdef HAS_QUAD
5180     Quad_t aquad;
5181     Uquad_t auquad;
5182 #endif
5183     char *aptr;
5184     float afloat;
5185     double adouble;
5186     int commas = 0;
5187 #ifdef PERL_NATINT_PACK
5188     int natint;         /* native integer */
5189 #endif
5190
5191     items = SP - MARK;
5192     MARK++;
5193     sv_setpvn(cat, "", 0);
5194     patcopy = pat;
5195     while (pat < patend) {
5196         SV *lengthcode = Nullsv;
5197 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5198         datumtype = *pat++ & 0xFF;
5199 #ifdef PERL_NATINT_PACK
5200         natint = 0;
5201 #endif
5202         if (isSPACE(datumtype)) {
5203             patcopy++;
5204             continue;
5205         }
5206 #ifndef PACKED_IS_OCTETS
5207         if (datumtype == 'U' && pat == patcopy+1)
5208             SvUTF8_on(cat);
5209 #endif
5210         if (datumtype == '#') {
5211             while (pat < patend && *pat != '\n')
5212                 pat++;
5213             continue;
5214         }
5215         if (*pat == '!') {
5216             char *natstr = "sSiIlL";
5217
5218             if (strchr(natstr, datumtype)) {
5219 #ifdef PERL_NATINT_PACK
5220                 natint = 1;
5221 #endif
5222                 pat++;
5223             }
5224             else
5225                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5226         }
5227         if (*pat == '*') {
5228             len = strchr("@Xxu", datumtype) ? 0 : items;
5229             pat++;
5230         }
5231         else if (isDIGIT(*pat)) {
5232             len = *pat++ - '0';
5233             while (isDIGIT(*pat)) {
5234                 len = (len * 10) + (*pat++ - '0');
5235                 if (len < 0)
5236                     DIE(aTHX_ "Repeat count in pack overflows");
5237             }
5238         }
5239         else
5240             len = 1;
5241         if (*pat == '/') {
5242             ++pat;
5243             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5244                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5245             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5246                                                    ? *MARK : &PL_sv_no)
5247                                             + (*pat == 'Z' ? 1 : 0)));
5248         }
5249         switch(datumtype) {
5250         default:
5251             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5252         case ',': /* grandfather in commas but with a warning */
5253             if (commas++ == 0 && ckWARN(WARN_PACK))
5254                 Perl_warner(aTHX_ WARN_PACK,
5255                             "Invalid type in pack: '%c'", (int)datumtype);
5256             break;
5257         case '%':
5258             DIE(aTHX_ "%% may only be used in unpack");
5259         case '@':
5260             len -= SvCUR(cat);
5261             if (len > 0)
5262                 goto grow;
5263             len = -len;
5264             if (len > 0)
5265                 goto shrink;
5266             break;
5267         case 'X':
5268           shrink:
5269             if (SvCUR(cat) < len)
5270                 DIE(aTHX_ "X outside of string");
5271             SvCUR(cat) -= len;
5272             *SvEND(cat) = '\0';
5273             break;
5274         case 'x':
5275           grow:
5276             while (len >= 10) {
5277                 sv_catpvn(cat, null10, 10);
5278                 len -= 10;
5279             }
5280             sv_catpvn(cat, null10, len);
5281             break;
5282         case 'A':
5283         case 'Z':
5284         case 'a':
5285             fromstr = NEXTFROM;
5286             aptr = SvPV(fromstr, fromlen);
5287             if (pat[-1] == '*') {
5288                 len = fromlen;
5289                 if (datumtype == 'Z')
5290                     ++len;
5291             }
5292             if (fromlen >= len) {
5293                 sv_catpvn(cat, aptr, len);
5294                 if (datumtype == 'Z')
5295                     *(SvEND(cat)-1) = '\0';
5296             }
5297             else {
5298                 sv_catpvn(cat, aptr, fromlen);
5299                 len -= fromlen;
5300                 if (datumtype == 'A') {
5301                     while (len >= 10) {
5302                         sv_catpvn(cat, space10, 10);
5303                         len -= 10;
5304                     }
5305                     sv_catpvn(cat, space10, len);
5306                 }
5307                 else {
5308                     while (len >= 10) {
5309                         sv_catpvn(cat, null10, 10);
5310                         len -= 10;
5311                     }
5312                     sv_catpvn(cat, null10, len);
5313                 }
5314             }
5315             break;
5316         case 'B':
5317         case 'b':
5318             {
5319                 register char *str;
5320                 I32 saveitems;
5321
5322                 fromstr = NEXTFROM;
5323                 saveitems = items;
5324                 str = SvPV(fromstr, fromlen);
5325                 if (pat[-1] == '*')
5326                     len = fromlen;
5327                 aint = SvCUR(cat);
5328                 SvCUR(cat) += (len+7)/8;
5329                 SvGROW(cat, SvCUR(cat) + 1);
5330                 aptr = SvPVX(cat) + aint;
5331                 if (len > fromlen)
5332                     len = fromlen;
5333                 aint = len;
5334                 items = 0;
5335                 if (datumtype == 'B') {
5336                     for (len = 0; len++ < aint;) {
5337                         items |= *str++ & 1;
5338                         if (len & 7)
5339                             items <<= 1;
5340                         else {
5341                             *aptr++ = items & 0xff;
5342                             items = 0;
5343                         }
5344                     }
5345                 }
5346                 else {
5347                     for (len = 0; len++ < aint;) {
5348                         if (*str++ & 1)
5349                             items |= 128;
5350                         if (len & 7)
5351                             items >>= 1;
5352                         else {
5353                             *aptr++ = items & 0xff;
5354                             items = 0;
5355                         }
5356                     }
5357                 }
5358                 if (aint & 7) {
5359                     if (datumtype == 'B')
5360                         items <<= 7 - (aint & 7);
5361                     else
5362                         items >>= 7 - (aint & 7);
5363                     *aptr++ = items & 0xff;
5364                 }
5365                 str = SvPVX(cat) + SvCUR(cat);
5366                 while (aptr <= str)
5367                     *aptr++ = '\0';
5368
5369                 items = saveitems;
5370             }
5371             break;
5372         case 'H':
5373         case 'h':
5374             {
5375                 register char *str;
5376                 I32 saveitems;
5377
5378                 fromstr = NEXTFROM;
5379                 saveitems = items;
5380                 str = SvPV(fromstr, fromlen);
5381                 if (pat[-1] == '*')
5382                     len = fromlen;
5383                 aint = SvCUR(cat);
5384                 SvCUR(cat) += (len+1)/2;
5385                 SvGROW(cat, SvCUR(cat) + 1);
5386                 aptr = SvPVX(cat) + aint;
5387                 if (len > fromlen)
5388                     len = fromlen;
5389                 aint = len;
5390                 items = 0;
5391                 if (datumtype == 'H') {
5392                     for (len = 0; len++ < aint;) {
5393                         if (isALPHA(*str))
5394                             items |= ((*str++ & 15) + 9) & 15;
5395                         else
5396                             items |= *str++ & 15;
5397                         if (len & 1)
5398                             items <<= 4;
5399                         else {
5400                             *aptr++ = items & 0xff;
5401                             items = 0;
5402                         }
5403                     }
5404                 }
5405                 else {
5406                     for (len = 0; len++ < aint;) {
5407                         if (isALPHA(*str))
5408                             items |= (((*str++ & 15) + 9) & 15) << 4;
5409                         else
5410                             items |= (*str++ & 15) << 4;
5411                         if (len & 1)
5412                             items >>= 4;
5413                         else {
5414                             *aptr++ = items & 0xff;
5415                             items = 0;
5416                         }
5417                     }
5418                 }
5419                 if (aint & 1)
5420                     *aptr++ = items & 0xff;
5421                 str = SvPVX(cat) + SvCUR(cat);
5422                 while (aptr <= str)
5423                     *aptr++ = '\0';
5424
5425                 items = saveitems;
5426             }
5427             break;
5428         case 'C':
5429         case 'c':
5430             while (len-- > 0) {
5431                 fromstr = NEXTFROM;
5432                 aint = SvIV(fromstr);
5433                 achar = aint;
5434                 sv_catpvn(cat, &achar, sizeof(char));
5435             }
5436             break;
5437         case 'U':
5438             while (len-- > 0) {
5439                 fromstr = NEXTFROM;
5440                 auint = SvUV(fromstr);
5441                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5442                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5443                                - SvPVX(cat));
5444             }
5445             *SvEND(cat) = '\0';
5446             break;
5447         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5448         case 'f':
5449         case 'F':
5450             while (len-- > 0) {
5451                 fromstr = NEXTFROM;
5452                 afloat = (float)SvNV(fromstr);
5453                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5454             }
5455             break;
5456         case 'd':
5457         case 'D':
5458             while (len-- > 0) {
5459                 fromstr = NEXTFROM;
5460                 adouble = (double)SvNV(fromstr);
5461                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5462             }
5463             break;
5464         case 'n':
5465             while (len-- > 0) {
5466                 fromstr = NEXTFROM;
5467                 ashort = (I16)SvIV(fromstr);
5468 #ifdef HAS_HTONS
5469                 ashort = PerlSock_htons(ashort);
5470 #endif
5471                 CAT16(cat, &ashort);
5472             }
5473             break;
5474         case 'v':
5475             while (len-- > 0) {
5476                 fromstr = NEXTFROM;
5477                 ashort = (I16)SvIV(fromstr);
5478 #ifdef HAS_HTOVS
5479                 ashort = htovs(ashort);
5480 #endif
5481                 CAT16(cat, &ashort);
5482             }
5483             break;
5484         case 'S':
5485 #if SHORTSIZE != SIZE16
5486             if (natint) {
5487                 unsigned short aushort;
5488
5489                 while (len-- > 0) {
5490                     fromstr = NEXTFROM;
5491                     aushort = SvUV(fromstr);
5492                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5493                 }
5494             }
5495             else
5496 #endif
5497             {
5498                 U16 aushort;
5499
5500                 while (len-- > 0) {
5501                     fromstr = NEXTFROM;
5502                     aushort = (U16)SvUV(fromstr);
5503                     CAT16(cat, &aushort);
5504                 }
5505
5506             }
5507             break;
5508         case 's':
5509 #if SHORTSIZE != SIZE16
5510             if (natint) {
5511                 short ashort;
5512
5513                 while (len-- > 0) {
5514                     fromstr = NEXTFROM;
5515                     ashort = SvIV(fromstr);
5516                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5517                 }
5518             }
5519             else
5520 #endif
5521             {
5522                 while (len-- > 0) {
5523                     fromstr = NEXTFROM;
5524                     ashort = (I16)SvIV(fromstr);
5525                     CAT16(cat, &ashort);
5526                 }
5527             }
5528             break;
5529         case 'I':
5530             while (len-- > 0) {
5531                 fromstr = NEXTFROM;
5532                 auint = SvUV(fromstr);
5533                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5534             }
5535             break;
5536         case 'w':
5537             while (len-- > 0) {
5538                 fromstr = NEXTFROM;
5539                 adouble = Perl_floor(SvNV(fromstr));
5540
5541                 if (adouble < 0)
5542                     DIE(aTHX_ "Cannot compress negative numbers");
5543
5544                 if (
5545 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5546                     adouble <= 0xffffffff
5547 #else
5548 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5549                     adouble <= UV_MAX_cxux
5550 #   else
5551                     adouble <= UV_MAX
5552 #   endif
5553 #endif
5554                     )
5555                 {
5556                     char   buf[1 + sizeof(UV)];
5557                     char  *in = buf + sizeof(buf);
5558                     UV     auv = U_V(adouble);
5559
5560                     do {
5561                         *--in = (auv & 0x7f) | 0x80;
5562                         auv >>= 7;
5563                     } while (auv);
5564                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5565                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5566                 }
5567                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5568                     char           *from, *result, *in;
5569                     SV             *norm;
5570                     STRLEN          len;
5571                     bool            done;
5572
5573                     /* Copy string and check for compliance */
5574                     from = SvPV(fromstr, len);
5575                     if ((norm = is_an_int(from, len)) == NULL)
5576                         DIE(aTHX_ "can compress only unsigned integer");
5577
5578                     New('w', result, len, char);
5579                     in = result + len;
5580                     done = FALSE;
5581                     while (!done)
5582                         *--in = div128(norm, &done) | 0x80;
5583                     result[len - 1] &= 0x7F; /* clear continue bit */
5584                     sv_catpvn(cat, in, (result + len) - in);
5585                     Safefree(result);
5586                     SvREFCNT_dec(norm); /* free norm */
5587                 }
5588                 else if (SvNOKp(fromstr)) {
5589                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5590                     char  *in = buf + sizeof(buf);
5591
5592                     do {
5593                         double next = floor(adouble / 128);
5594                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5595                         if (in <= buf)  /* this cannot happen ;-) */
5596                             DIE(aTHX_ "Cannot compress integer");
5597                         in--;
5598                         adouble = next;
5599                     } while (adouble > 0);
5600                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5601                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5602                 }
5603                 else
5604                     DIE(aTHX_ "Cannot compress non integer");
5605             }
5606             break;
5607         case 'i':
5608             while (len-- > 0) {
5609                 fromstr = NEXTFROM;
5610                 aint = SvIV(fromstr);
5611                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5612             }
5613             break;
5614         case 'N':
5615             while (len-- > 0) {
5616                 fromstr = NEXTFROM;
5617                 aulong = SvUV(fromstr);
5618 #ifdef HAS_HTONL
5619                 aulong = PerlSock_htonl(aulong);
5620 #endif
5621                 CAT32(cat, &aulong);
5622             }
5623             break;
5624         case 'V':
5625             while (len-- > 0) {
5626                 fromstr = NEXTFROM;
5627                 aulong = SvUV(fromstr);
5628 #ifdef HAS_HTOVL
5629                 aulong = htovl(aulong);
5630 #endif
5631                 CAT32(cat, &aulong);
5632             }
5633             break;
5634         case 'L':
5635 #if LONGSIZE != SIZE32
5636             if (natint) {
5637                 unsigned long aulong;
5638
5639                 while (len-- > 0) {
5640                     fromstr = NEXTFROM;
5641                     aulong = SvUV(fromstr);
5642                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5643                 }
5644             }
5645             else
5646 #endif
5647             {
5648                 while (len-- > 0) {
5649                     fromstr = NEXTFROM;
5650                     aulong = SvUV(fromstr);
5651                     CAT32(cat, &aulong);
5652                 }
5653             }
5654             break;
5655         case 'l':
5656 #if LONGSIZE != SIZE32
5657             if (natint) {
5658                 long along;
5659
5660                 while (len-- > 0) {
5661                     fromstr = NEXTFROM;
5662                     along = SvIV(fromstr);
5663                     sv_catpvn(cat, (char *)&along, sizeof(long));
5664                 }
5665             }
5666             else
5667 #endif
5668             {
5669                 while (len-- > 0) {
5670                     fromstr = NEXTFROM;
5671                     along = SvIV(fromstr);
5672                     CAT32(cat, &along);
5673                 }
5674             }
5675             break;
5676 #ifdef HAS_QUAD
5677         case 'Q':
5678             while (len-- > 0) {
5679                 fromstr = NEXTFROM;
5680                 auquad = (Uquad_t)SvUV(fromstr);
5681                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5682             }
5683             break;
5684         case 'q':
5685             while (len-- > 0) {
5686                 fromstr = NEXTFROM;
5687                 aquad = (Quad_t)SvIV(fromstr);
5688                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5689             }
5690             break;
5691 #endif
5692         case 'P':
5693             len = 1;            /* assume SV is correct length */
5694             /* FALL THROUGH */
5695         case 'p':
5696             while (len-- > 0) {
5697                 fromstr = NEXTFROM;
5698                 if (fromstr == &PL_sv_undef)
5699                     aptr = NULL;
5700                 else {
5701                     STRLEN n_a;
5702                     /* XXX better yet, could spirit away the string to
5703                      * a safe spot and hang on to it until the result
5704                      * of pack() (and all copies of the result) are
5705                      * gone.
5706                      */
5707                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5708                                                 || (SvPADTMP(fromstr)
5709                                                     && !SvREADONLY(fromstr))))
5710                     {
5711                         Perl_warner(aTHX_ WARN_PACK,
5712                                 "Attempt to pack pointer to temporary value");
5713                     }
5714                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5715                         aptr = SvPV(fromstr,n_a);
5716                     else
5717                         aptr = SvPV_force(fromstr,n_a);
5718                 }
5719                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5720             }
5721             break;
5722         case 'u':
5723             fromstr = NEXTFROM;
5724             aptr = SvPV(fromstr, fromlen);
5725             SvGROW(cat, fromlen * 4 / 3);
5726             if (len <= 1)
5727                 len = 45;
5728             else
5729                 len = len / 3 * 3;
5730             while (fromlen > 0) {
5731                 I32 todo;
5732
5733                 if (fromlen > len)
5734                     todo = len;
5735                 else
5736                     todo = fromlen;
5737                 doencodes(cat, aptr, todo);
5738                 fromlen -= todo;
5739                 aptr += todo;
5740             }
5741             break;
5742         }
5743     }
5744     SvSETMAGIC(cat);
5745     SP = ORIGMARK;
5746     PUSHs(cat);
5747     RETURN;
5748 }
5749 #undef NEXTFROM
5750
5751
5752 PP(pp_split)
5753 {
5754     dSP; dTARG;
5755     AV *ary;
5756     register IV limit = POPi;                   /* note, negative is forever */
5757     SV *sv = POPs;
5758     STRLEN len;
5759     register char *s = SvPV(sv, len);
5760     bool do_utf8 = DO_UTF8(sv);
5761     char *strend = s + len;
5762     register PMOP *pm;
5763     register REGEXP *rx;
5764     register SV *dstr;
5765     register char *m;
5766     I32 iters = 0;
5767     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5768     I32 maxiters = slen + 10;
5769     I32 i;
5770     char *orig;
5771     I32 origlimit = limit;
5772     I32 realarray = 0;
5773     I32 base;
5774     AV *oldstack = PL_curstack;
5775     I32 gimme = GIMME_V;
5776     I32 oldsave = PL_savestack_ix;
5777     I32 make_mortal = 1;
5778     MAGIC *mg = (MAGIC *) NULL;
5779
5780 #ifdef DEBUGGING
5781     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5782 #else
5783     pm = (PMOP*)POPs;
5784 #endif
5785     if (!pm || !s)
5786         DIE(aTHX_ "panic: pp_split");
5787     rx = pm->op_pmregexp;
5788
5789     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5790              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5791
5792     if (pm->op_pmreplroot) {
5793 #ifdef USE_ITHREADS
5794         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5795 #else
5796         ary = GvAVn((GV*)pm->op_pmreplroot);
5797 #endif
5798     }
5799     else if (gimme != G_ARRAY)
5800 #ifdef USE_THREADS
5801         ary = (AV*)PL_curpad[0];
5802 #else
5803         ary = GvAVn(PL_defgv);
5804 #endif /* USE_THREADS */
5805     else
5806         ary = Nullav;
5807     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5808         realarray = 1;
5809         PUTBACK;
5810         av_extend(ary,0);
5811         av_clear(ary);
5812         SPAGAIN;
5813         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5814             PUSHMARK(SP);
5815             XPUSHs(SvTIED_obj((SV*)ary, mg));
5816         }
5817         else {
5818             if (!AvREAL(ary)) {
5819                 AvREAL_on(ary);
5820                 AvREIFY_off(ary);
5821                 for (i = AvFILLp(ary); i >= 0; i--)
5822                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5823             }
5824             /* temporarily switch stacks */
5825             SWITCHSTACK(PL_curstack, ary);
5826             make_mortal = 0;
5827         }
5828     }
5829     base = SP - PL_stack_base;
5830     orig = s;
5831     if (pm->op_pmflags & PMf_SKIPWHITE) {
5832         if (pm->op_pmflags & PMf_LOCALE) {
5833             while (isSPACE_LC(*s))
5834                 s++;
5835         }
5836         else {
5837             while (isSPACE(*s))
5838                 s++;
5839         }
5840     }
5841     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5842         SAVEINT(PL_multiline);
5843         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5844     }
5845
5846     if (!limit)
5847         limit = maxiters + 2;
5848     if (pm->op_pmflags & PMf_WHITE) {
5849         while (--limit) {
5850             m = s;
5851             while (m < strend &&
5852                    !((pm->op_pmflags & PMf_LOCALE)
5853                      ? isSPACE_LC(*m) : isSPACE(*m)))
5854                 ++m;
5855             if (m >= strend)
5856                 break;
5857
5858             dstr = NEWSV(30, m-s);
5859             sv_setpvn(dstr, s, m-s);
5860             if (make_mortal)
5861                 sv_2mortal(dstr);
5862             if (do_utf8)
5863                 (void)SvUTF8_on(dstr);
5864             XPUSHs(dstr);
5865
5866             s = m + 1;
5867             while (s < strend &&
5868                    ((pm->op_pmflags & PMf_LOCALE)
5869                     ? isSPACE_LC(*s) : isSPACE(*s)))
5870                 ++s;
5871         }
5872     }
5873     else if (strEQ("^", rx->precomp)) {
5874         while (--limit) {
5875             /*SUPPRESS 530*/
5876             for (m = s; m < strend && *m != '\n'; m++) ;
5877             m++;
5878             if (m >= strend)
5879                 break;
5880             dstr = NEWSV(30, m-s);
5881             sv_setpvn(dstr, s, m-s);
5882             if (make_mortal)
5883                 sv_2mortal(dstr);
5884             if (do_utf8)
5885                 (void)SvUTF8_on(dstr);
5886             XPUSHs(dstr);
5887             s = m;
5888         }
5889     }
5890     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5891              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5892              && (rx->reganch & ROPT_CHECK_ALL)
5893              && !(rx->reganch & ROPT_ANCH)) {
5894         int tail = (rx->reganch & RE_INTUIT_TAIL);
5895         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5896
5897         len = rx->minlen;
5898         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5899             STRLEN n_a;
5900             char c = *SvPV(csv, n_a);
5901             while (--limit) {
5902                 /*SUPPRESS 530*/
5903                 for (m = s; m < strend && *m != c; m++) ;
5904                 if (m >= strend)
5905                     break;
5906                 dstr = NEWSV(30, m-s);
5907                 sv_setpvn(dstr, s, m-s);
5908                 if (make_mortal)
5909                     sv_2mortal(dstr);
5910                 if (do_utf8)
5911                     (void)SvUTF8_on(dstr);
5912                 XPUSHs(dstr);
5913                 /* The rx->minlen is in characters but we want to step
5914                  * s ahead by bytes. */
5915                 if (do_utf8)
5916                     s = (char*)utf8_hop((U8*)m, len);
5917                 else
5918                     s = m + len; /* Fake \n at the end */
5919             }
5920         }
5921         else {
5922 #ifndef lint
5923             while (s < strend && --limit &&
5924               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5925                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5926 #endif
5927             {
5928                 dstr = NEWSV(31, m-s);
5929                 sv_setpvn(dstr, s, m-s);
5930                 if (make_mortal)
5931                     sv_2mortal(dstr);
5932                 if (do_utf8)
5933                     (void)SvUTF8_on(dstr);
5934                 XPUSHs(dstr);
5935                 /* The rx->minlen is in characters but we want to step
5936                  * s ahead by bytes. */
5937                 if (do_utf8)
5938                     s = (char*)utf8_hop((U8*)m, len);
5939                 else
5940                     s = m + len; /* Fake \n at the end */
5941             }
5942         }
5943     }
5944     else {
5945         maxiters += slen * rx->nparens;
5946         while (s < strend && --limit
5947 /*             && (!rx->check_substr
5948                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5949                                                  0, NULL))))
5950 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5951                               1 /* minend */, sv, NULL, 0))
5952         {
5953             TAINT_IF(RX_MATCH_TAINTED(rx));
5954             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5955                 m = s;
5956                 s = orig;
5957                 orig = rx->subbeg;
5958                 s = orig + (m - s);
5959                 strend = s + (strend - m);
5960             }
5961             m = rx->startp[0] + orig;
5962             dstr = NEWSV(32, m-s);
5963             sv_setpvn(dstr, s, m-s);
5964             if (make_mortal)
5965                 sv_2mortal(dstr);
5966             if (do_utf8)
5967                 (void)SvUTF8_on(dstr);
5968             XPUSHs(dstr);
5969             if (rx->nparens) {
5970                 for (i = 1; i <= rx->nparens; i++) {
5971                     s = rx->startp[i] + orig;
5972                     m = rx->endp[i] + orig;
5973                     if (m && s) {
5974                         dstr = NEWSV(33, m-s);
5975                         sv_setpvn(dstr, s, m-s);
5976                     }
5977                     else
5978                         dstr = NEWSV(33, 0);
5979                     if (make_mortal)
5980                         sv_2mortal(dstr);
5981                     if (do_utf8)
5982                         (void)SvUTF8_on(dstr);
5983                     XPUSHs(dstr);
5984                 }
5985             }
5986             s = rx->endp[0] + orig;
5987         }
5988     }
5989
5990     LEAVE_SCOPE(oldsave);
5991     iters = (SP - PL_stack_base) - base;
5992     if (iters > maxiters)
5993         DIE(aTHX_ "Split loop");
5994
5995     /* keep field after final delim? */
5996     if (s < strend || (iters && origlimit)) {
5997         STRLEN l = strend - s;
5998         dstr = NEWSV(34, l);
5999         sv_setpvn(dstr, s, l);
6000         if (make_mortal)
6001             sv_2mortal(dstr);
6002         if (do_utf8)
6003             (void)SvUTF8_on(dstr);
6004         XPUSHs(dstr);
6005         iters++;
6006     }
6007     else if (!origlimit) {
6008         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6009             iters--, SP--;
6010     }
6011
6012     if (realarray) {
6013         if (!mg) {
6014             SWITCHSTACK(ary, oldstack);
6015             if (SvSMAGICAL(ary)) {
6016                 PUTBACK;
6017                 mg_set((SV*)ary);
6018                 SPAGAIN;
6019             }
6020             if (gimme == G_ARRAY) {
6021                 EXTEND(SP, iters);
6022                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6023                 SP += iters;
6024                 RETURN;
6025             }
6026         }
6027         else {
6028             PUTBACK;
6029             ENTER;
6030             call_method("PUSH",G_SCALAR|G_DISCARD);
6031             LEAVE;
6032             SPAGAIN;
6033             if (gimme == G_ARRAY) {
6034                 /* EXTEND should not be needed - we just popped them */
6035                 EXTEND(SP, iters);
6036                 for (i=0; i < iters; i++) {
6037                     SV **svp = av_fetch(ary, i, FALSE);
6038                     PUSHs((svp) ? *svp : &PL_sv_undef);
6039                 }
6040                 RETURN;
6041             }
6042         }
6043     }
6044     else {
6045         if (gimme == G_ARRAY)
6046             RETURN;
6047     }
6048     if (iters || !pm->op_pmreplroot) {
6049         GETTARGET;
6050         PUSHi(iters);
6051         RETURN;
6052     }
6053     RETPUSHUNDEF;
6054 }
6055
6056 #ifdef USE_THREADS
6057 void
6058 Perl_unlock_condpair(pTHX_ void *svv)
6059 {
6060     MAGIC *mg = mg_find((SV*)svv, 'm');
6061
6062     if (!mg)
6063         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6064     MUTEX_LOCK(MgMUTEXP(mg));
6065     if (MgOWNER(mg) != thr)
6066         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6067     MgOWNER(mg) = 0;
6068     COND_SIGNAL(MgOWNERCONDP(mg));
6069     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6070                           PTR2UV(thr), PTR2UV(svv));)
6071     MUTEX_UNLOCK(MgMUTEXP(mg));
6072 }
6073 #endif /* USE_THREADS */
6074
6075 PP(pp_lock)
6076 {
6077     dSP;
6078     dTOPss;
6079     SV *retsv = sv;
6080 #ifdef USE_THREADS
6081     sv_lock(sv);
6082 #endif /* USE_THREADS */
6083     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6084         || SvTYPE(retsv) == SVt_PVCV) {
6085         retsv = refto(retsv);
6086     }
6087     SETs(retsv);
6088     RETURN;
6089 }
6090
6091 PP(pp_threadsv)
6092 {
6093 #ifdef USE_THREADS
6094     dSP;
6095     EXTEND(SP, 1);
6096     if (PL_op->op_private & OPpLVAL_INTRO)
6097         PUSHs(*save_threadsv(PL_op->op_targ));
6098     else
6099         PUSHs(THREADSV(PL_op->op_targ));
6100     RETURN;
6101 #else
6102     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6103 #endif /* USE_THREADS */
6104 }