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