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_INVARIANT(*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
4040 PP(pp_unpack)
4041 {
4042     dSP;
4043     dPOPPOPssrl;
4044     I32 start_sp_offset = SP - PL_stack_base;
4045     I32 gimme = GIMME_V;
4046     SV *sv;
4047     STRLEN llen;
4048     STRLEN rlen;
4049     register char *pat = SvPV(left, llen);
4050 #ifdef PACKED_IS_OCTETS
4051     /* Packed side is assumed to be octets - so force downgrade if it
4052        has been UTF-8 encoded by accident
4053      */
4054     register char *s = SvPVbyte(right, rlen);
4055 #else
4056     register char *s = SvPV(right, rlen);
4057 #endif
4058     char *strend = s + rlen;
4059     char *strbeg = s;
4060     register char *patend = pat + llen;
4061     I32 datumtype;
4062     register I32 len;
4063     register I32 bits;
4064     register char *str;
4065
4066     /* These must not be in registers: */
4067     short ashort;
4068     int aint;
4069     long along;
4070 #ifdef HAS_QUAD
4071     Quad_t aquad;
4072 #endif
4073     U16 aushort;
4074     unsigned int auint;
4075     U32 aulong;
4076 #ifdef HAS_QUAD
4077     Uquad_t auquad;
4078 #endif
4079     char *aptr;
4080     float afloat;
4081     double adouble;
4082     I32 checksum = 0;
4083     register U32 culong;
4084     NV cdouble;
4085     int commas = 0;
4086     int star;
4087 #ifdef PERL_NATINT_PACK
4088     int natint;         /* native integer */
4089     int unatint;        /* unsigned native integer */
4090 #endif
4091
4092     if (gimme != G_ARRAY) {             /* arrange to do first one only */
4093         /*SUPPRESS 530*/
4094         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4095         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4096             patend++;
4097             while (isDIGIT(*patend) || *patend == '*')
4098                 patend++;
4099         }
4100         else
4101             patend++;
4102     }
4103     while (pat < patend) {
4104       reparse:
4105         datumtype = *pat++ & 0xFF;
4106 #ifdef PERL_NATINT_PACK
4107         natint = 0;
4108 #endif
4109         if (isSPACE(datumtype))
4110             continue;
4111         if (datumtype == '#') {
4112             while (pat < patend && *pat != '\n')
4113                 pat++;
4114             continue;
4115         }
4116         if (*pat == '!') {
4117             char *natstr = "sSiIlL";
4118
4119             if (strchr(natstr, datumtype)) {
4120 #ifdef PERL_NATINT_PACK
4121                 natint = 1;
4122 #endif
4123                 pat++;
4124             }
4125             else
4126                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4127         }
4128         star = 0;
4129         if (pat >= patend)
4130             len = 1;
4131         else if (*pat == '*') {
4132             len = strend - strbeg;      /* long enough */
4133             pat++;
4134             star = 1;
4135         }
4136         else if (isDIGIT(*pat)) {
4137             len = *pat++ - '0';
4138             while (isDIGIT(*pat)) {
4139                 len = (len * 10) + (*pat++ - '0');
4140                 if (len < 0)
4141                     DIE(aTHX_ "Repeat count in unpack overflows");
4142             }
4143         }
4144         else
4145             len = (datumtype != '@');
4146       redo_switch:
4147         switch(datumtype) {
4148         default:
4149             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4150         case ',': /* grandfather in commas but with a warning */
4151             if (commas++ == 0 && ckWARN(WARN_UNPACK))
4152                 Perl_warner(aTHX_ WARN_UNPACK,
4153                             "Invalid type in unpack: '%c'", (int)datumtype);
4154             break;
4155         case '%':
4156             if (len == 1 && pat[-1] != '1')
4157                 len = 16;
4158             checksum = len;
4159             culong = 0;
4160             cdouble = 0;
4161             if (pat < patend)
4162                 goto reparse;
4163             break;
4164         case '@':
4165             if (len > strend - strbeg)
4166                 DIE(aTHX_ "@ outside of string");
4167             s = strbeg + len;
4168             break;
4169         case 'X':
4170             if (len > s - strbeg)
4171                 DIE(aTHX_ "X outside of string");
4172             s -= len;
4173             break;
4174         case 'x':
4175             if (len > strend - s)
4176                 DIE(aTHX_ "x outside of string");
4177             s += len;
4178             break;
4179         case '/':
4180             if (start_sp_offset >= SP - PL_stack_base)
4181                 DIE(aTHX_ "/ must follow a numeric type");
4182             datumtype = *pat++;
4183             if (*pat == '*')
4184                 pat++;          /* ignore '*' for compatibility with pack */
4185             if (isDIGIT(*pat))
4186                 DIE(aTHX_ "/ cannot take a count" );
4187             len = POPi;
4188             star = 0;
4189             goto redo_switch;
4190         case 'A':
4191         case 'Z':
4192         case 'a':
4193             if (len > strend - s)
4194                 len = strend - s;
4195             if (checksum)
4196                 goto uchar_checksum;
4197             sv = NEWSV(35, len);
4198             sv_setpvn(sv, s, len);
4199             s += len;
4200             if (datumtype == 'A' || datumtype == 'Z') {
4201                 aptr = s;       /* borrow register */
4202                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4203                     s = SvPVX(sv);
4204                     while (*s)
4205                         s++;
4206                 }
4207                 else {          /* 'A' strips both nulls and spaces */
4208                     s = SvPVX(sv) + len - 1;
4209                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4210                         s--;
4211                     *++s = '\0';
4212                 }
4213                 SvCUR_set(sv, s - SvPVX(sv));
4214                 s = aptr;       /* unborrow register */
4215             }
4216             XPUSHs(sv_2mortal(sv));
4217             break;
4218         case 'B':
4219         case 'b':
4220             if (star || len > (strend - s) * 8)
4221                 len = (strend - s) * 8;
4222             if (checksum) {
4223                 if (!PL_bitcount) {
4224                     Newz(601, PL_bitcount, 256, char);
4225                     for (bits = 1; bits < 256; bits++) {
4226                         if (bits & 1)   PL_bitcount[bits]++;
4227                         if (bits & 2)   PL_bitcount[bits]++;
4228                         if (bits & 4)   PL_bitcount[bits]++;
4229                         if (bits & 8)   PL_bitcount[bits]++;
4230                         if (bits & 16)  PL_bitcount[bits]++;
4231                         if (bits & 32)  PL_bitcount[bits]++;
4232                         if (bits & 64)  PL_bitcount[bits]++;
4233                         if (bits & 128) PL_bitcount[bits]++;
4234                     }
4235                 }
4236                 while (len >= 8) {
4237                     culong += PL_bitcount[*(unsigned char*)s++];
4238                     len -= 8;
4239                 }
4240                 if (len) {
4241                     bits = *s;
4242                     if (datumtype == 'b') {
4243                         while (len-- > 0) {
4244                             if (bits & 1) culong++;
4245                             bits >>= 1;
4246                         }
4247                     }
4248                     else {
4249                         while (len-- > 0) {
4250                             if (bits & 128) culong++;
4251                             bits <<= 1;
4252                         }
4253                     }
4254                 }
4255                 break;
4256             }
4257             sv = NEWSV(35, len + 1);
4258             SvCUR_set(sv, len);
4259             SvPOK_on(sv);
4260             str = SvPVX(sv);
4261             if (datumtype == 'b') {
4262                 aint = len;
4263                 for (len = 0; len < aint; len++) {
4264                     if (len & 7)                /*SUPPRESS 595*/
4265                         bits >>= 1;
4266                     else
4267                         bits = *s++;
4268                     *str++ = '0' + (bits & 1);
4269                 }
4270             }
4271             else {
4272                 aint = len;
4273                 for (len = 0; len < aint; len++) {
4274                     if (len & 7)
4275                         bits <<= 1;
4276                     else
4277                         bits = *s++;
4278                     *str++ = '0' + ((bits & 128) != 0);
4279                 }
4280             }
4281             *str = '\0';
4282             XPUSHs(sv_2mortal(sv));
4283             break;
4284         case 'H':
4285         case 'h':
4286             if (star || len > (strend - s) * 2)
4287                 len = (strend - s) * 2;
4288             sv = NEWSV(35, len + 1);
4289             SvCUR_set(sv, len);
4290             SvPOK_on(sv);
4291             str = SvPVX(sv);
4292             if (datumtype == 'h') {
4293                 aint = len;
4294                 for (len = 0; len < aint; len++) {
4295                     if (len & 1)
4296                         bits >>= 4;
4297                     else
4298                         bits = *s++;
4299                     *str++ = PL_hexdigit[bits & 15];
4300                 }
4301             }
4302             else {
4303                 aint = len;
4304                 for (len = 0; len < aint; len++) {
4305                     if (len & 1)
4306                         bits <<= 4;
4307                     else
4308                         bits = *s++;
4309                     *str++ = PL_hexdigit[(bits >> 4) & 15];
4310                 }
4311             }
4312             *str = '\0';
4313             XPUSHs(sv_2mortal(sv));
4314             break;
4315         case 'c':
4316             if (len > strend - s)
4317                 len = strend - s;
4318             if (checksum) {
4319                 while (len-- > 0) {
4320                     aint = *s++;
4321                     if (aint >= 128)    /* fake up signed chars */
4322                         aint -= 256;
4323                     culong += aint;
4324                 }
4325             }
4326             else {
4327                 EXTEND(SP, len);
4328                 EXTEND_MORTAL(len);
4329                 while (len-- > 0) {
4330                     aint = *s++;
4331                     if (aint >= 128)    /* fake up signed chars */
4332                         aint -= 256;
4333                     sv = NEWSV(36, 0);
4334                     sv_setiv(sv, (IV)aint);
4335                     PUSHs(sv_2mortal(sv));
4336                 }
4337             }
4338             break;
4339         case 'C':
4340             if (len > strend - s)
4341                 len = strend - s;
4342             if (checksum) {
4343               uchar_checksum:
4344                 while (len-- > 0) {
4345                     auint = *s++ & 255;
4346                     culong += auint;
4347                 }
4348             }
4349             else {
4350                 EXTEND(SP, len);
4351                 EXTEND_MORTAL(len);
4352                 while (len-- > 0) {
4353                     auint = *s++ & 255;
4354                     sv = NEWSV(37, 0);
4355                     sv_setiv(sv, (IV)auint);
4356                     PUSHs(sv_2mortal(sv));
4357                 }
4358             }
4359             break;
4360         case 'U':
4361             if (len > strend - s)
4362                 len = strend - s;
4363             if (checksum) {
4364                 while (len-- > 0 && s < strend) {
4365                     STRLEN alen;
4366                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4367                     along = alen;
4368                     s += along;
4369                     if (checksum > 32)
4370                         cdouble += (NV)auint;
4371                     else
4372                         culong += auint;
4373                 }
4374             }
4375             else {
4376                 EXTEND(SP, len);
4377                 EXTEND_MORTAL(len);
4378                 while (len-- > 0 && s < strend) {
4379                     STRLEN alen;
4380                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4381                     along = alen;
4382                     s += along;
4383                     sv = NEWSV(37, 0);
4384                     sv_setuv(sv, (UV)auint);
4385                     PUSHs(sv_2mortal(sv));
4386                 }
4387             }
4388             break;
4389         case 's':
4390 #if SHORTSIZE == SIZE16
4391             along = (strend - s) / SIZE16;
4392 #else
4393             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4394 #endif
4395             if (len > along)
4396                 len = along;
4397             if (checksum) {
4398 #if SHORTSIZE != SIZE16
4399                 if (natint) {
4400                     short ashort;
4401                     while (len-- > 0) {
4402                         COPYNN(s, &ashort, sizeof(short));
4403                         s += sizeof(short);
4404                         culong += ashort;
4405
4406                     }
4407                 }
4408                 else
4409 #endif
4410                 {
4411                     while (len-- > 0) {
4412                         COPY16(s, &ashort);
4413 #if SHORTSIZE > SIZE16
4414                         if (ashort > 32767)
4415                           ashort -= 65536;
4416 #endif
4417                         s += SIZE16;
4418                         culong += ashort;
4419                     }
4420                 }
4421             }
4422             else {
4423                 EXTEND(SP, len);
4424                 EXTEND_MORTAL(len);
4425 #if SHORTSIZE != SIZE16
4426                 if (natint) {
4427                     short ashort;
4428                     while (len-- > 0) {
4429                         COPYNN(s, &ashort, sizeof(short));
4430                         s += sizeof(short);
4431                         sv = NEWSV(38, 0);
4432                         sv_setiv(sv, (IV)ashort);
4433                         PUSHs(sv_2mortal(sv));
4434                     }
4435                 }
4436                 else
4437 #endif
4438                 {
4439                     while (len-- > 0) {
4440                         COPY16(s, &ashort);
4441 #if SHORTSIZE > SIZE16
4442                         if (ashort > 32767)
4443                           ashort -= 65536;
4444 #endif
4445                         s += SIZE16;
4446                         sv = NEWSV(38, 0);
4447                         sv_setiv(sv, (IV)ashort);
4448                         PUSHs(sv_2mortal(sv));
4449                     }
4450                 }
4451             }
4452             break;
4453         case 'v':
4454         case 'n':
4455         case 'S':
4456 #if SHORTSIZE == SIZE16
4457             along = (strend - s) / SIZE16;
4458 #else
4459             unatint = natint && datumtype == 'S';
4460             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4461 #endif
4462             if (len > along)
4463                 len = along;
4464             if (checksum) {
4465 #if SHORTSIZE != SIZE16
4466                 if (unatint) {
4467                     unsigned short aushort;
4468                     while (len-- > 0) {
4469                         COPYNN(s, &aushort, sizeof(unsigned short));
4470                         s += sizeof(unsigned short);
4471                         culong += aushort;
4472                     }
4473                 }
4474                 else
4475 #endif
4476                 {
4477                     while (len-- > 0) {
4478                         COPY16(s, &aushort);
4479                         s += SIZE16;
4480 #ifdef HAS_NTOHS
4481                         if (datumtype == 'n')
4482                             aushort = PerlSock_ntohs(aushort);
4483 #endif
4484 #ifdef HAS_VTOHS
4485                         if (datumtype == 'v')
4486                             aushort = vtohs(aushort);
4487 #endif
4488                         culong += aushort;
4489                     }
4490                 }
4491             }
4492             else {
4493                 EXTEND(SP, len);
4494                 EXTEND_MORTAL(len);
4495 #if SHORTSIZE != SIZE16
4496                 if (unatint) {
4497                     unsigned short aushort;
4498                     while (len-- > 0) {
4499                         COPYNN(s, &aushort, sizeof(unsigned short));
4500                         s += sizeof(unsigned short);
4501                         sv = NEWSV(39, 0);
4502                         sv_setiv(sv, (UV)aushort);
4503                         PUSHs(sv_2mortal(sv));
4504                     }
4505                 }
4506                 else
4507 #endif
4508                 {
4509                     while (len-- > 0) {
4510                         COPY16(s, &aushort);
4511                         s += SIZE16;
4512                         sv = NEWSV(39, 0);
4513 #ifdef HAS_NTOHS
4514                         if (datumtype == 'n')
4515                             aushort = PerlSock_ntohs(aushort);
4516 #endif
4517 #ifdef HAS_VTOHS
4518                         if (datumtype == 'v')
4519                             aushort = vtohs(aushort);
4520 #endif
4521                         sv_setiv(sv, (UV)aushort);
4522                         PUSHs(sv_2mortal(sv));
4523                     }
4524                 }
4525             }
4526             break;
4527         case 'i':
4528             along = (strend - s) / sizeof(int);
4529             if (len > along)
4530                 len = along;
4531             if (checksum) {
4532                 while (len-- > 0) {
4533                     Copy(s, &aint, 1, int);
4534                     s += sizeof(int);
4535                     if (checksum > 32)
4536                         cdouble += (NV)aint;
4537                     else
4538                         culong += aint;
4539                 }
4540             }
4541             else {
4542                 EXTEND(SP, len);
4543                 EXTEND_MORTAL(len);
4544                 while (len-- > 0) {
4545                     Copy(s, &aint, 1, int);
4546                     s += sizeof(int);
4547                     sv = NEWSV(40, 0);
4548 #ifdef __osf__
4549                     /* Without the dummy below unpack("i", pack("i",-1))
4550                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4551                      * cc with optimization turned on.
4552                      *
4553                      * The bug was detected in
4554                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4555                      * with optimization (-O4) turned on.
4556                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4557                      * does not have this problem even with -O4.
4558                      *
4559                      * This bug was reported as DECC_BUGS 1431
4560                      * and tracked internally as GEM_BUGS 7775.
4561                      *
4562                      * The bug is fixed in
4563                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
4564                      * UNIX V4.0F support:   DEC C V5.9-006 or later
4565                      * UNIX V4.0E support:   DEC C V5.8-011 or later
4566                      * and also in DTK.
4567                      *
4568                      * See also few lines later for the same bug.
4569                      */
4570                     (aint) ?
4571                         sv_setiv(sv, (IV)aint) :
4572 #endif
4573                     sv_setiv(sv, (IV)aint);
4574                     PUSHs(sv_2mortal(sv));
4575                 }
4576             }
4577             break;
4578         case 'I':
4579             along = (strend - s) / sizeof(unsigned int);
4580             if (len > along)
4581                 len = along;
4582             if (checksum) {
4583                 while (len-- > 0) {
4584                     Copy(s, &auint, 1, unsigned int);
4585                     s += sizeof(unsigned int);
4586                     if (checksum > 32)
4587                         cdouble += (NV)auint;
4588                     else
4589                         culong += auint;
4590                 }
4591             }
4592             else {
4593                 EXTEND(SP, len);
4594                 EXTEND_MORTAL(len);
4595                 while (len-- > 0) {
4596                     Copy(s, &auint, 1, unsigned int);
4597                     s += sizeof(unsigned int);
4598                     sv = NEWSV(41, 0);
4599 #ifdef __osf__
4600                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4601                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4602                      * See details few lines earlier. */
4603                     (auint) ?
4604                         sv_setuv(sv, (UV)auint) :
4605 #endif
4606                     sv_setuv(sv, (UV)auint);
4607                     PUSHs(sv_2mortal(sv));
4608                 }
4609             }
4610             break;
4611         case 'l':
4612 #if LONGSIZE == SIZE32
4613             along = (strend - s) / SIZE32;
4614 #else
4615             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4616 #endif
4617             if (len > along)
4618                 len = along;
4619             if (checksum) {
4620 #if LONGSIZE != SIZE32
4621                 if (natint) {
4622                     while (len-- > 0) {
4623                         COPYNN(s, &along, sizeof(long));
4624                         s += sizeof(long);
4625                         if (checksum > 32)
4626                             cdouble += (NV)along;
4627                         else
4628                             culong += along;
4629                     }
4630                 }
4631                 else
4632 #endif
4633                 {
4634                     while (len-- > 0) {
4635 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4636                         I32 along;
4637 #endif
4638                         COPY32(s, &along);
4639 #if LONGSIZE > SIZE32
4640                         if (along > 2147483647)
4641                           along -= 4294967296;
4642 #endif
4643                         s += SIZE32;
4644                         if (checksum > 32)
4645                             cdouble += (NV)along;
4646                         else
4647                             culong += along;
4648                     }
4649                 }
4650             }
4651             else {
4652                 EXTEND(SP, len);
4653                 EXTEND_MORTAL(len);
4654 #if LONGSIZE != SIZE32
4655                 if (natint) {
4656                     while (len-- > 0) {
4657                         COPYNN(s, &along, sizeof(long));
4658                         s += sizeof(long);
4659                         sv = NEWSV(42, 0);
4660                         sv_setiv(sv, (IV)along);
4661                         PUSHs(sv_2mortal(sv));
4662                     }
4663                 }
4664                 else
4665 #endif
4666                 {
4667                     while (len-- > 0) {
4668 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4669                         I32 along;
4670 #endif
4671                         COPY32(s, &along);
4672 #if LONGSIZE > SIZE32
4673                         if (along > 2147483647)
4674                           along -= 4294967296;
4675 #endif
4676                         s += SIZE32;
4677                         sv = NEWSV(42, 0);
4678                         sv_setiv(sv, (IV)along);
4679                         PUSHs(sv_2mortal(sv));
4680                     }
4681                 }
4682             }
4683             break;
4684         case 'V':
4685         case 'N':
4686         case 'L':
4687 #if LONGSIZE == SIZE32
4688             along = (strend - s) / SIZE32;
4689 #else
4690             unatint = natint && datumtype == 'L';
4691             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4692 #endif
4693             if (len > along)
4694                 len = along;
4695             if (checksum) {
4696 #if LONGSIZE != SIZE32
4697                 if (unatint) {
4698                     unsigned long aulong;
4699                     while (len-- > 0) {
4700                         COPYNN(s, &aulong, sizeof(unsigned long));
4701                         s += sizeof(unsigned long);
4702                         if (checksum > 32)
4703                             cdouble += (NV)aulong;
4704                         else
4705                             culong += aulong;
4706                     }
4707                 }
4708                 else
4709 #endif
4710                 {
4711                     while (len-- > 0) {
4712                         COPY32(s, &aulong);
4713                         s += SIZE32;
4714 #ifdef HAS_NTOHL
4715                         if (datumtype == 'N')
4716                             aulong = PerlSock_ntohl(aulong);
4717 #endif
4718 #ifdef HAS_VTOHL
4719                         if (datumtype == 'V')
4720                             aulong = vtohl(aulong);
4721 #endif
4722                         if (checksum > 32)
4723                             cdouble += (NV)aulong;
4724                         else
4725                             culong += aulong;
4726                     }
4727                 }
4728             }
4729             else {
4730                 EXTEND(SP, len);
4731                 EXTEND_MORTAL(len);
4732 #if LONGSIZE != SIZE32
4733                 if (unatint) {
4734                     unsigned long aulong;
4735                     while (len-- > 0) {
4736                         COPYNN(s, &aulong, sizeof(unsigned long));
4737                         s += sizeof(unsigned long);
4738                         sv = NEWSV(43, 0);
4739                         sv_setuv(sv, (UV)aulong);
4740                         PUSHs(sv_2mortal(sv));
4741                     }
4742                 }
4743                 else
4744 #endif
4745                 {
4746                     while (len-- > 0) {
4747                         COPY32(s, &aulong);
4748                         s += SIZE32;
4749 #ifdef HAS_NTOHL
4750                         if (datumtype == 'N')
4751                             aulong = PerlSock_ntohl(aulong);
4752 #endif
4753 #ifdef HAS_VTOHL
4754                         if (datumtype == 'V')
4755                             aulong = vtohl(aulong);
4756 #endif
4757                         sv = NEWSV(43, 0);
4758                         sv_setuv(sv, (UV)aulong);
4759                         PUSHs(sv_2mortal(sv));
4760                     }
4761                 }
4762             }
4763             break;
4764         case 'p':
4765             along = (strend - s) / sizeof(char*);
4766             if (len > along)
4767                 len = along;
4768             EXTEND(SP, len);
4769             EXTEND_MORTAL(len);
4770             while (len-- > 0) {
4771                 if (sizeof(char*) > strend - s)
4772                     break;
4773                 else {
4774                     Copy(s, &aptr, 1, char*);
4775                     s += sizeof(char*);
4776                 }
4777                 sv = NEWSV(44, 0);
4778                 if (aptr)
4779                     sv_setpv(sv, aptr);
4780                 PUSHs(sv_2mortal(sv));
4781             }
4782             break;
4783         case 'w':
4784             EXTEND(SP, len);
4785             EXTEND_MORTAL(len);
4786             {
4787                 UV auv = 0;
4788                 U32 bytes = 0;
4789
4790                 while ((len > 0) && (s < strend)) {
4791                     auv = (auv << 7) | (*s & 0x7f);
4792                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4793                     if ((U8)(*s++) < 0x80) {
4794                         bytes = 0;
4795                         sv = NEWSV(40, 0);
4796                         sv_setuv(sv, auv);
4797                         PUSHs(sv_2mortal(sv));
4798                         len--;
4799                         auv = 0;
4800                     }
4801                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4802                         char *t;
4803                         STRLEN n_a;
4804
4805                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4806                         while (s < strend) {
4807                             sv = mul128(sv, *s & 0x7f);
4808                             if (!(*s++ & 0x80)) {
4809                                 bytes = 0;
4810                                 break;
4811                             }
4812                         }
4813                         t = SvPV(sv, n_a);
4814                         while (*t == '0')
4815                             t++;
4816                         sv_chop(sv, t);
4817                         PUSHs(sv_2mortal(sv));
4818                         len--;
4819                         auv = 0;
4820                     }
4821                 }
4822                 if ((s >= strend) && bytes)
4823                     DIE(aTHX_ "Unterminated compressed integer");
4824             }
4825             break;
4826         case 'P':
4827             EXTEND(SP, 1);
4828             if (sizeof(char*) > strend - s)
4829                 break;
4830             else {
4831                 Copy(s, &aptr, 1, char*);
4832                 s += sizeof(char*);
4833             }
4834             sv = NEWSV(44, 0);
4835             if (aptr)
4836                 sv_setpvn(sv, aptr, len);
4837             PUSHs(sv_2mortal(sv));
4838             break;
4839 #ifdef HAS_QUAD
4840         case 'q':
4841             along = (strend - s) / sizeof(Quad_t);
4842             if (len > along)
4843                 len = along;
4844             EXTEND(SP, len);
4845             EXTEND_MORTAL(len);
4846             while (len-- > 0) {
4847                 if (s + sizeof(Quad_t) > strend)
4848                     aquad = 0;
4849                 else {
4850                     Copy(s, &aquad, 1, Quad_t);
4851                     s += sizeof(Quad_t);
4852                 }
4853                 sv = NEWSV(42, 0);
4854                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4855                     sv_setiv(sv, (IV)aquad);
4856                 else
4857                     sv_setnv(sv, (NV)aquad);
4858                 PUSHs(sv_2mortal(sv));
4859             }
4860             break;
4861         case 'Q':
4862             along = (strend - s) / sizeof(Quad_t);
4863             if (len > along)
4864                 len = along;
4865             EXTEND(SP, len);
4866             EXTEND_MORTAL(len);
4867             while (len-- > 0) {
4868                 if (s + sizeof(Uquad_t) > strend)
4869                     auquad = 0;
4870                 else {
4871                     Copy(s, &auquad, 1, Uquad_t);
4872                     s += sizeof(Uquad_t);
4873                 }
4874                 sv = NEWSV(43, 0);
4875                 if (auquad <= UV_MAX)
4876                     sv_setuv(sv, (UV)auquad);
4877                 else
4878                     sv_setnv(sv, (NV)auquad);
4879                 PUSHs(sv_2mortal(sv));
4880             }
4881             break;
4882 #endif
4883         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4884         case 'f':
4885         case 'F':
4886             along = (strend - s) / sizeof(float);
4887             if (len > along)
4888                 len = along;
4889             if (checksum) {
4890                 while (len-- > 0) {
4891                     Copy(s, &afloat, 1, float);
4892                     s += sizeof(float);
4893                     cdouble += afloat;
4894                 }
4895             }
4896             else {
4897                 EXTEND(SP, len);
4898                 EXTEND_MORTAL(len);
4899                 while (len-- > 0) {
4900                     Copy(s, &afloat, 1, float);
4901                     s += sizeof(float);
4902                     sv = NEWSV(47, 0);
4903                     sv_setnv(sv, (NV)afloat);
4904                     PUSHs(sv_2mortal(sv));
4905                 }
4906             }
4907             break;
4908         case 'd':
4909         case 'D':
4910             along = (strend - s) / sizeof(double);
4911             if (len > along)
4912                 len = along;
4913             if (checksum) {
4914                 while (len-- > 0) {
4915                     Copy(s, &adouble, 1, double);
4916                     s += sizeof(double);
4917                     cdouble += adouble;
4918                 }
4919             }
4920             else {
4921                 EXTEND(SP, len);
4922                 EXTEND_MORTAL(len);
4923                 while (len-- > 0) {
4924                     Copy(s, &adouble, 1, double);
4925                     s += sizeof(double);
4926                     sv = NEWSV(48, 0);
4927                     sv_setnv(sv, (NV)adouble);
4928                     PUSHs(sv_2mortal(sv));
4929                 }
4930             }
4931             break;
4932         case 'u':
4933             /* MKS:
4934              * Initialise the decode mapping.  By using a table driven
4935              * algorithm, the code will be character-set independent
4936              * (and just as fast as doing character arithmetic)
4937              */
4938             if (PL_uudmap['M'] == 0) {
4939                 int i;
4940
4941                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4942                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4943                 /*
4944                  * Because ' ' and '`' map to the same value,
4945                  * we need to decode them both the same.
4946                  */
4947                 PL_uudmap[' '] = 0;
4948             }
4949
4950             along = (strend - s) * 3 / 4;
4951             sv = NEWSV(42, along);
4952             if (along)
4953                 SvPOK_on(sv);
4954             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4955                 I32 a, b, c, d;
4956                 char hunk[4];
4957
4958                 hunk[3] = '\0';
4959                 len = PL_uudmap[*(U8*)s++] & 077;
4960                 while (len > 0) {
4961                     if (s < strend && ISUUCHAR(*s))
4962                         a = PL_uudmap[*(U8*)s++] & 077;
4963                     else
4964                         a = 0;
4965                     if (s < strend && ISUUCHAR(*s))
4966                         b = PL_uudmap[*(U8*)s++] & 077;
4967                     else
4968                         b = 0;
4969                     if (s < strend && ISUUCHAR(*s))
4970                         c = PL_uudmap[*(U8*)s++] & 077;
4971                     else
4972                         c = 0;
4973                     if (s < strend && ISUUCHAR(*s))
4974                         d = PL_uudmap[*(U8*)s++] & 077;
4975                     else
4976                         d = 0;
4977                     hunk[0] = (a << 2) | (b >> 4);
4978                     hunk[1] = (b << 4) | (c >> 2);
4979                     hunk[2] = (c << 6) | d;
4980                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4981                     len -= 3;
4982                 }
4983                 if (*s == '\n')
4984                     s++;
4985                 else if (s[1] == '\n')          /* possible checksum byte */
4986                     s += 2;
4987             }
4988             XPUSHs(sv_2mortal(sv));
4989             break;
4990         }
4991         if (checksum) {
4992             sv = NEWSV(42, 0);
4993             if (strchr("fFdD", datumtype) ||
4994               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4995                 NV trouble;
4996
4997                 adouble = 1.0;
4998                 while (checksum >= 16) {
4999                     checksum -= 16;
5000                     adouble *= 65536.0;
5001                 }
5002                 while (checksum >= 4) {
5003                     checksum -= 4;
5004                     adouble *= 16.0;
5005                 }
5006                 while (checksum--)
5007                     adouble *= 2.0;
5008                 along = (1 << checksum) - 1;
5009                 while (cdouble < 0.0)
5010                     cdouble += adouble;
5011                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5012                 sv_setnv(sv, cdouble);
5013             }
5014             else {
5015                 if (checksum < 32) {
5016                     aulong = (1 << checksum) - 1;
5017                     culong &= aulong;
5018                 }
5019                 sv_setuv(sv, (UV)culong);
5020             }
5021             XPUSHs(sv_2mortal(sv));
5022             checksum = 0;
5023         }
5024     }
5025     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5026         PUSHs(&PL_sv_undef);
5027     RETURN;
5028 }
5029
5030 STATIC void
5031 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5032 {
5033     char hunk[5];
5034
5035     *hunk = PL_uuemap[len];
5036     sv_catpvn(sv, hunk, 1);
5037     hunk[4] = '\0';
5038     while (len > 2) {
5039         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5040         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5041         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5042         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5043         sv_catpvn(sv, hunk, 4);
5044         s += 3;
5045         len -= 3;
5046     }
5047     if (len > 0) {
5048         char r = (len > 1 ? s[1] : '\0');
5049         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5050         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5051         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5052         hunk[3] = PL_uuemap[0];
5053         sv_catpvn(sv, hunk, 4);
5054     }
5055     sv_catpvn(sv, "\n", 1);
5056 }
5057
5058 STATIC SV *
5059 S_is_an_int(pTHX_ char *s, STRLEN l)
5060 {
5061   STRLEN         n_a;
5062   SV             *result = newSVpvn(s, l);
5063   char           *result_c = SvPV(result, n_a); /* convenience */
5064   char           *out = result_c;
5065   bool            skip = 1;
5066   bool            ignore = 0;
5067
5068   while (*s) {
5069     switch (*s) {
5070     case ' ':
5071       break;
5072     case '+':
5073       if (!skip) {
5074         SvREFCNT_dec(result);
5075         return (NULL);
5076       }
5077       break;
5078     case '0':
5079     case '1':
5080     case '2':
5081     case '3':
5082     case '4':
5083     case '5':
5084     case '6':
5085     case '7':
5086     case '8':
5087     case '9':
5088       skip = 0;
5089       if (!ignore) {
5090         *(out++) = *s;
5091       }
5092       break;
5093     case '.':
5094       ignore = 1;
5095       break;
5096     default:
5097       SvREFCNT_dec(result);
5098       return (NULL);
5099     }
5100     s++;
5101   }
5102   *(out++) = '\0';
5103   SvCUR_set(result, out - result_c);
5104   return (result);
5105 }
5106
5107 /* pnum must be '\0' terminated */
5108 STATIC int
5109 S_div128(pTHX_ SV *pnum, bool *done)
5110 {
5111   STRLEN          len;
5112   char           *s = SvPV(pnum, len);
5113   int             m = 0;
5114   int             r = 0;
5115   char           *t = s;
5116
5117   *done = 1;
5118   while (*t) {
5119     int             i;
5120
5121     i = m * 10 + (*t - '0');
5122     m = i & 0x7F;
5123     r = (i >> 7);               /* r < 10 */
5124     if (r) {
5125       *done = 0;
5126     }
5127     *(t++) = '0' + r;
5128   }
5129   *(t++) = '\0';
5130   SvCUR_set(pnum, (STRLEN) (t - s));
5131   return (m);
5132 }
5133
5134
5135 PP(pp_pack)
5136 {
5137     dSP; dMARK; dORIGMARK; dTARGET;
5138     register SV *cat = TARG;
5139     register I32 items;
5140     STRLEN fromlen;
5141     register char *pat = SvPVx(*++MARK, fromlen);
5142     char *patcopy;
5143     register char *patend = pat + fromlen;
5144     register I32 len;
5145     I32 datumtype;
5146     SV *fromstr;
5147     /*SUPPRESS 442*/
5148     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5149     static char *space10 = "          ";
5150
5151     /* These must not be in registers: */
5152     char achar;
5153     I16 ashort;
5154     int aint;
5155     unsigned int auint;
5156     I32 along;
5157     U32 aulong;
5158 #ifdef HAS_QUAD
5159     Quad_t aquad;
5160     Uquad_t auquad;
5161 #endif
5162     char *aptr;
5163     float afloat;
5164     double adouble;
5165     int commas = 0;
5166 #ifdef PERL_NATINT_PACK
5167     int natint;         /* native integer */
5168 #endif
5169
5170     items = SP - MARK;
5171     MARK++;
5172     sv_setpvn(cat, "", 0);
5173     patcopy = pat;
5174     while (pat < patend) {
5175         SV *lengthcode = Nullsv;
5176 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5177         datumtype = *pat++ & 0xFF;
5178 #ifdef PERL_NATINT_PACK
5179         natint = 0;
5180 #endif
5181         if (isSPACE(datumtype)) {
5182             patcopy++;
5183             continue;
5184         }
5185 #ifndef PACKED_IS_OCTETS
5186         if (datumtype == 'U' && pat == patcopy+1)
5187             SvUTF8_on(cat);
5188 #endif
5189         if (datumtype == '#') {
5190             while (pat < patend && *pat != '\n')
5191                 pat++;
5192             continue;
5193         }
5194         if (*pat == '!') {
5195             char *natstr = "sSiIlL";
5196
5197             if (strchr(natstr, datumtype)) {
5198 #ifdef PERL_NATINT_PACK
5199                 natint = 1;
5200 #endif
5201                 pat++;
5202             }
5203             else
5204                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5205         }
5206         if (*pat == '*') {
5207             len = strchr("@Xxu", datumtype) ? 0 : items;
5208             pat++;
5209         }
5210         else if (isDIGIT(*pat)) {
5211             len = *pat++ - '0';
5212             while (isDIGIT(*pat)) {
5213                 len = (len * 10) + (*pat++ - '0');
5214                 if (len < 0)
5215                     DIE(aTHX_ "Repeat count in pack overflows");
5216             }
5217         }
5218         else
5219             len = 1;
5220         if (*pat == '/') {
5221             ++pat;
5222             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5223                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5224             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5225                                                    ? *MARK : &PL_sv_no)
5226                                             + (*pat == 'Z' ? 1 : 0)));
5227         }
5228         switch(datumtype) {
5229         default:
5230             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5231         case ',': /* grandfather in commas but with a warning */
5232             if (commas++ == 0 && ckWARN(WARN_PACK))
5233                 Perl_warner(aTHX_ WARN_PACK,
5234                             "Invalid type in pack: '%c'", (int)datumtype);
5235             break;
5236         case '%':
5237             DIE(aTHX_ "%% may only be used in unpack");
5238         case '@':
5239             len -= SvCUR(cat);
5240             if (len > 0)
5241                 goto grow;
5242             len = -len;
5243             if (len > 0)
5244                 goto shrink;
5245             break;
5246         case 'X':
5247           shrink:
5248             if (SvCUR(cat) < len)
5249                 DIE(aTHX_ "X outside of string");
5250             SvCUR(cat) -= len;
5251             *SvEND(cat) = '\0';
5252             break;
5253         case 'x':
5254           grow:
5255             while (len >= 10) {
5256                 sv_catpvn(cat, null10, 10);
5257                 len -= 10;
5258             }
5259             sv_catpvn(cat, null10, len);
5260             break;
5261         case 'A':
5262         case 'Z':
5263         case 'a':
5264             fromstr = NEXTFROM;
5265             aptr = SvPV(fromstr, fromlen);
5266             if (pat[-1] == '*') {
5267                 len = fromlen;
5268                 if (datumtype == 'Z')
5269                     ++len;
5270             }
5271             if (fromlen >= len) {
5272                 sv_catpvn(cat, aptr, len);
5273                 if (datumtype == 'Z')
5274                     *(SvEND(cat)-1) = '\0';
5275             }
5276             else {
5277                 sv_catpvn(cat, aptr, fromlen);
5278                 len -= fromlen;
5279                 if (datumtype == 'A') {
5280                     while (len >= 10) {
5281                         sv_catpvn(cat, space10, 10);
5282                         len -= 10;
5283                     }
5284                     sv_catpvn(cat, space10, len);
5285                 }
5286                 else {
5287                     while (len >= 10) {
5288                         sv_catpvn(cat, null10, 10);
5289                         len -= 10;
5290                     }
5291                     sv_catpvn(cat, null10, len);
5292                 }
5293             }
5294             break;
5295         case 'B':
5296         case 'b':
5297             {
5298                 register char *str;
5299                 I32 saveitems;
5300
5301                 fromstr = NEXTFROM;
5302                 saveitems = items;
5303                 str = SvPV(fromstr, fromlen);
5304                 if (pat[-1] == '*')
5305                     len = fromlen;
5306                 aint = SvCUR(cat);
5307                 SvCUR(cat) += (len+7)/8;
5308                 SvGROW(cat, SvCUR(cat) + 1);
5309                 aptr = SvPVX(cat) + aint;
5310                 if (len > fromlen)
5311                     len = fromlen;
5312                 aint = len;
5313                 items = 0;
5314                 if (datumtype == 'B') {
5315                     for (len = 0; len++ < aint;) {
5316                         items |= *str++ & 1;
5317                         if (len & 7)
5318                             items <<= 1;
5319                         else {
5320                             *aptr++ = items & 0xff;
5321                             items = 0;
5322                         }
5323                     }
5324                 }
5325                 else {
5326                     for (len = 0; len++ < aint;) {
5327                         if (*str++ & 1)
5328                             items |= 128;
5329                         if (len & 7)
5330                             items >>= 1;
5331                         else {
5332                             *aptr++ = items & 0xff;
5333                             items = 0;
5334                         }
5335                     }
5336                 }
5337                 if (aint & 7) {
5338                     if (datumtype == 'B')
5339                         items <<= 7 - (aint & 7);
5340                     else
5341                         items >>= 7 - (aint & 7);
5342                     *aptr++ = items & 0xff;
5343                 }
5344                 str = SvPVX(cat) + SvCUR(cat);
5345                 while (aptr <= str)
5346                     *aptr++ = '\0';
5347
5348                 items = saveitems;
5349             }
5350             break;
5351         case 'H':
5352         case 'h':
5353             {
5354                 register char *str;
5355                 I32 saveitems;
5356
5357                 fromstr = NEXTFROM;
5358                 saveitems = items;
5359                 str = SvPV(fromstr, fromlen);
5360                 if (pat[-1] == '*')
5361                     len = fromlen;
5362                 aint = SvCUR(cat);
5363                 SvCUR(cat) += (len+1)/2;
5364                 SvGROW(cat, SvCUR(cat) + 1);
5365                 aptr = SvPVX(cat) + aint;
5366                 if (len > fromlen)
5367                     len = fromlen;
5368                 aint = len;
5369                 items = 0;
5370                 if (datumtype == 'H') {
5371                     for (len = 0; len++ < aint;) {
5372                         if (isALPHA(*str))
5373                             items |= ((*str++ & 15) + 9) & 15;
5374                         else
5375                             items |= *str++ & 15;
5376                         if (len & 1)
5377                             items <<= 4;
5378                         else {
5379                             *aptr++ = items & 0xff;
5380                             items = 0;
5381                         }
5382                     }
5383                 }
5384                 else {
5385                     for (len = 0; len++ < aint;) {
5386                         if (isALPHA(*str))
5387                             items |= (((*str++ & 15) + 9) & 15) << 4;
5388                         else
5389                             items |= (*str++ & 15) << 4;
5390                         if (len & 1)
5391                             items >>= 4;
5392                         else {
5393                             *aptr++ = items & 0xff;
5394                             items = 0;
5395                         }
5396                     }
5397                 }
5398                 if (aint & 1)
5399                     *aptr++ = items & 0xff;
5400                 str = SvPVX(cat) + SvCUR(cat);
5401                 while (aptr <= str)
5402                     *aptr++ = '\0';
5403
5404                 items = saveitems;
5405             }
5406             break;
5407         case 'C':
5408         case 'c':
5409             while (len-- > 0) {
5410                 fromstr = NEXTFROM;
5411                 aint = SvIV(fromstr);
5412                 achar = aint;
5413                 sv_catpvn(cat, &achar, sizeof(char));
5414             }
5415             break;
5416         case 'U':
5417             while (len-- > 0) {
5418                 fromstr = NEXTFROM;
5419                 auint = SvUV(fromstr);
5420                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5421                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5422                                - SvPVX(cat));
5423             }
5424             *SvEND(cat) = '\0';
5425             break;
5426         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5427         case 'f':
5428         case 'F':
5429             while (len-- > 0) {
5430                 fromstr = NEXTFROM;
5431                 afloat = (float)SvNV(fromstr);
5432                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5433             }
5434             break;
5435         case 'd':
5436         case 'D':
5437             while (len-- > 0) {
5438                 fromstr = NEXTFROM;
5439                 adouble = (double)SvNV(fromstr);
5440                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5441             }
5442             break;
5443         case 'n':
5444             while (len-- > 0) {
5445                 fromstr = NEXTFROM;
5446                 ashort = (I16)SvIV(fromstr);
5447 #ifdef HAS_HTONS
5448                 ashort = PerlSock_htons(ashort);
5449 #endif
5450                 CAT16(cat, &ashort);
5451             }
5452             break;
5453         case 'v':
5454             while (len-- > 0) {
5455                 fromstr = NEXTFROM;
5456                 ashort = (I16)SvIV(fromstr);
5457 #ifdef HAS_HTOVS
5458                 ashort = htovs(ashort);
5459 #endif
5460                 CAT16(cat, &ashort);
5461             }
5462             break;
5463         case 'S':
5464 #if SHORTSIZE != SIZE16
5465             if (natint) {
5466                 unsigned short aushort;
5467
5468                 while (len-- > 0) {
5469                     fromstr = NEXTFROM;
5470                     aushort = SvUV(fromstr);
5471                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5472                 }
5473             }
5474             else
5475 #endif
5476             {
5477                 U16 aushort;
5478
5479                 while (len-- > 0) {
5480                     fromstr = NEXTFROM;
5481                     aushort = (U16)SvUV(fromstr);
5482                     CAT16(cat, &aushort);
5483                 }
5484
5485             }
5486             break;
5487         case 's':
5488 #if SHORTSIZE != SIZE16
5489             if (natint) {
5490                 short ashort;
5491
5492                 while (len-- > 0) {
5493                     fromstr = NEXTFROM;
5494                     ashort = SvIV(fromstr);
5495                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5496                 }
5497             }
5498             else
5499 #endif
5500             {
5501                 while (len-- > 0) {
5502                     fromstr = NEXTFROM;
5503                     ashort = (I16)SvIV(fromstr);
5504                     CAT16(cat, &ashort);
5505                 }
5506             }
5507             break;
5508         case 'I':
5509             while (len-- > 0) {
5510                 fromstr = NEXTFROM;
5511                 auint = SvUV(fromstr);
5512                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5513             }
5514             break;
5515         case 'w':
5516             while (len-- > 0) {
5517                 fromstr = NEXTFROM;
5518                 adouble = Perl_floor(SvNV(fromstr));
5519
5520                 if (adouble < 0)
5521                     DIE(aTHX_ "Cannot compress negative numbers");
5522
5523                 if (
5524 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5525                     adouble <= 0xffffffff
5526 #else
5527 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5528                     adouble <= UV_MAX_cxux
5529 #   else
5530                     adouble <= UV_MAX
5531 #   endif
5532 #endif
5533                     )
5534                 {
5535                     char   buf[1 + sizeof(UV)];
5536                     char  *in = buf + sizeof(buf);
5537                     UV     auv = U_V(adouble);
5538
5539                     do {
5540                         *--in = (auv & 0x7f) | 0x80;
5541                         auv >>= 7;
5542                     } while (auv);
5543                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5544                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5545                 }
5546                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5547                     char           *from, *result, *in;
5548                     SV             *norm;
5549                     STRLEN          len;
5550                     bool            done;
5551
5552                     /* Copy string and check for compliance */
5553                     from = SvPV(fromstr, len);
5554                     if ((norm = is_an_int(from, len)) == NULL)
5555                         DIE(aTHX_ "can compress only unsigned integer");
5556
5557                     New('w', result, len, char);
5558                     in = result + len;
5559                     done = FALSE;
5560                     while (!done)
5561                         *--in = div128(norm, &done) | 0x80;
5562                     result[len - 1] &= 0x7F; /* clear continue bit */
5563                     sv_catpvn(cat, in, (result + len) - in);
5564                     Safefree(result);
5565                     SvREFCNT_dec(norm); /* free norm */
5566                 }
5567                 else if (SvNOKp(fromstr)) {
5568                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5569                     char  *in = buf + sizeof(buf);
5570
5571                     do {
5572                         double next = floor(adouble / 128);
5573                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5574                         if (in <= buf)  /* this cannot happen ;-) */
5575                             DIE(aTHX_ "Cannot compress integer");
5576                         in--;
5577                         adouble = next;
5578                     } while (adouble > 0);
5579                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5580                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5581                 }
5582                 else
5583                     DIE(aTHX_ "Cannot compress non integer");
5584             }
5585             break;
5586         case 'i':
5587             while (len-- > 0) {
5588                 fromstr = NEXTFROM;
5589                 aint = SvIV(fromstr);
5590                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5591             }
5592             break;
5593         case 'N':
5594             while (len-- > 0) {
5595                 fromstr = NEXTFROM;
5596                 aulong = SvUV(fromstr);
5597 #ifdef HAS_HTONL
5598                 aulong = PerlSock_htonl(aulong);
5599 #endif
5600                 CAT32(cat, &aulong);
5601             }
5602             break;
5603         case 'V':
5604             while (len-- > 0) {
5605                 fromstr = NEXTFROM;
5606                 aulong = SvUV(fromstr);
5607 #ifdef HAS_HTOVL
5608                 aulong = htovl(aulong);
5609 #endif
5610                 CAT32(cat, &aulong);
5611             }
5612             break;
5613         case 'L':
5614 #if LONGSIZE != SIZE32
5615             if (natint) {
5616                 unsigned long aulong;
5617
5618                 while (len-- > 0) {
5619                     fromstr = NEXTFROM;
5620                     aulong = SvUV(fromstr);
5621                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5622                 }
5623             }
5624             else
5625 #endif
5626             {
5627                 while (len-- > 0) {
5628                     fromstr = NEXTFROM;
5629                     aulong = SvUV(fromstr);
5630                     CAT32(cat, &aulong);
5631                 }
5632             }
5633             break;
5634         case 'l':
5635 #if LONGSIZE != SIZE32
5636             if (natint) {
5637                 long along;
5638
5639                 while (len-- > 0) {
5640                     fromstr = NEXTFROM;
5641                     along = SvIV(fromstr);
5642                     sv_catpvn(cat, (char *)&along, sizeof(long));
5643                 }
5644             }
5645             else
5646 #endif
5647             {
5648                 while (len-- > 0) {
5649                     fromstr = NEXTFROM;
5650                     along = SvIV(fromstr);
5651                     CAT32(cat, &along);
5652                 }
5653             }
5654             break;
5655 #ifdef HAS_QUAD
5656         case 'Q':
5657             while (len-- > 0) {
5658                 fromstr = NEXTFROM;
5659                 auquad = (Uquad_t)SvUV(fromstr);
5660                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5661             }
5662             break;
5663         case 'q':
5664             while (len-- > 0) {
5665                 fromstr = NEXTFROM;
5666                 aquad = (Quad_t)SvIV(fromstr);
5667                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5668             }
5669             break;
5670 #endif
5671         case 'P':
5672             len = 1;            /* assume SV is correct length */
5673             /* FALL THROUGH */
5674         case 'p':
5675             while (len-- > 0) {
5676                 fromstr = NEXTFROM;
5677                 if (fromstr == &PL_sv_undef)
5678                     aptr = NULL;
5679                 else {
5680                     STRLEN n_a;
5681                     /* XXX better yet, could spirit away the string to
5682                      * a safe spot and hang on to it until the result
5683                      * of pack() (and all copies of the result) are
5684                      * gone.
5685                      */
5686                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5687                                                 || (SvPADTMP(fromstr)
5688                                                     && !SvREADONLY(fromstr))))
5689                     {
5690                         Perl_warner(aTHX_ WARN_PACK,
5691                                 "Attempt to pack pointer to temporary value");
5692                     }
5693                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5694                         aptr = SvPV(fromstr,n_a);
5695                     else
5696                         aptr = SvPV_force(fromstr,n_a);
5697                 }
5698                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5699             }
5700             break;
5701         case 'u':
5702             fromstr = NEXTFROM;
5703             aptr = SvPV(fromstr, fromlen);
5704             SvGROW(cat, fromlen * 4 / 3);
5705             if (len <= 1)
5706                 len = 45;
5707             else
5708                 len = len / 3 * 3;
5709             while (fromlen > 0) {
5710                 I32 todo;
5711
5712                 if (fromlen > len)
5713                     todo = len;
5714                 else
5715                     todo = fromlen;
5716                 doencodes(cat, aptr, todo);
5717                 fromlen -= todo;
5718                 aptr += todo;
5719             }
5720             break;
5721         }
5722     }
5723     SvSETMAGIC(cat);
5724     SP = ORIGMARK;
5725     PUSHs(cat);
5726     RETURN;
5727 }
5728 #undef NEXTFROM
5729
5730
5731 PP(pp_split)
5732 {
5733     dSP; dTARG;
5734     AV *ary;
5735     register IV limit = POPi;                   /* note, negative is forever */
5736     SV *sv = POPs;
5737     STRLEN len;
5738     register char *s = SvPV(sv, len);
5739     bool do_utf8 = DO_UTF8(sv);
5740     char *strend = s + len;
5741     register PMOP *pm;
5742     register REGEXP *rx;
5743     register SV *dstr;
5744     register char *m;
5745     I32 iters = 0;
5746     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5747     I32 maxiters = slen + 10;
5748     I32 i;
5749     char *orig;
5750     I32 origlimit = limit;
5751     I32 realarray = 0;
5752     I32 base;
5753     AV *oldstack = PL_curstack;
5754     I32 gimme = GIMME_V;
5755     I32 oldsave = PL_savestack_ix;
5756     I32 make_mortal = 1;
5757     MAGIC *mg = (MAGIC *) NULL;
5758
5759 #ifdef DEBUGGING
5760     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5761 #else
5762     pm = (PMOP*)POPs;
5763 #endif
5764     if (!pm || !s)
5765         DIE(aTHX_ "panic: pp_split");
5766     rx = pm->op_pmregexp;
5767
5768     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5769              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5770
5771     if (pm->op_pmreplroot) {
5772 #ifdef USE_ITHREADS
5773         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5774 #else
5775         ary = GvAVn((GV*)pm->op_pmreplroot);
5776 #endif
5777     }
5778     else if (gimme != G_ARRAY)
5779 #ifdef USE_THREADS
5780         ary = (AV*)PL_curpad[0];
5781 #else
5782         ary = GvAVn(PL_defgv);
5783 #endif /* USE_THREADS */
5784     else
5785         ary = Nullav;
5786     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5787         realarray = 1;
5788         PUTBACK;
5789         av_extend(ary,0);
5790         av_clear(ary);
5791         SPAGAIN;
5792         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5793             PUSHMARK(SP);
5794             XPUSHs(SvTIED_obj((SV*)ary, mg));
5795         }
5796         else {
5797             if (!AvREAL(ary)) {
5798                 AvREAL_on(ary);
5799                 AvREIFY_off(ary);
5800                 for (i = AvFILLp(ary); i >= 0; i--)
5801                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5802             }
5803             /* temporarily switch stacks */
5804             SWITCHSTACK(PL_curstack, ary);
5805             make_mortal = 0;
5806         }
5807     }
5808     base = SP - PL_stack_base;
5809     orig = s;
5810     if (pm->op_pmflags & PMf_SKIPWHITE) {
5811         if (pm->op_pmflags & PMf_LOCALE) {
5812             while (isSPACE_LC(*s))
5813                 s++;
5814         }
5815         else {
5816             while (isSPACE(*s))
5817                 s++;
5818         }
5819     }
5820     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5821         SAVEINT(PL_multiline);
5822         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5823     }
5824
5825     if (!limit)
5826         limit = maxiters + 2;
5827     if (pm->op_pmflags & PMf_WHITE) {
5828         while (--limit) {
5829             m = s;
5830             while (m < strend &&
5831                    !((pm->op_pmflags & PMf_LOCALE)
5832                      ? isSPACE_LC(*m) : isSPACE(*m)))
5833                 ++m;
5834             if (m >= strend)
5835                 break;
5836
5837             dstr = NEWSV(30, m-s);
5838             sv_setpvn(dstr, s, m-s);
5839             if (make_mortal)
5840                 sv_2mortal(dstr);
5841             if (do_utf8)
5842                 (void)SvUTF8_on(dstr);
5843             XPUSHs(dstr);
5844
5845             s = m + 1;
5846             while (s < strend &&
5847                    ((pm->op_pmflags & PMf_LOCALE)
5848                     ? isSPACE_LC(*s) : isSPACE(*s)))
5849                 ++s;
5850         }
5851     }
5852     else if (strEQ("^", rx->precomp)) {
5853         while (--limit) {
5854             /*SUPPRESS 530*/
5855             for (m = s; m < strend && *m != '\n'; m++) ;
5856             m++;
5857             if (m >= strend)
5858                 break;
5859             dstr = NEWSV(30, m-s);
5860             sv_setpvn(dstr, s, m-s);
5861             if (make_mortal)
5862                 sv_2mortal(dstr);
5863             if (do_utf8)
5864                 (void)SvUTF8_on(dstr);
5865             XPUSHs(dstr);
5866             s = m;
5867         }
5868     }
5869     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5870              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5871              && (rx->reganch & ROPT_CHECK_ALL)
5872              && !(rx->reganch & ROPT_ANCH)) {
5873         int tail = (rx->reganch & RE_INTUIT_TAIL);
5874         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5875
5876         len = rx->minlen;
5877         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5878             STRLEN n_a;
5879             char c = *SvPV(csv, n_a);
5880             while (--limit) {
5881                 /*SUPPRESS 530*/
5882                 for (m = s; m < strend && *m != c; m++) ;
5883                 if (m >= strend)
5884                     break;
5885                 dstr = NEWSV(30, m-s);
5886                 sv_setpvn(dstr, s, m-s);
5887                 if (make_mortal)
5888                     sv_2mortal(dstr);
5889                 if (do_utf8)
5890                     (void)SvUTF8_on(dstr);
5891                 XPUSHs(dstr);
5892                 /* The rx->minlen is in characters but we want to step
5893                  * s ahead by bytes. */
5894                 if (do_utf8)
5895                     s = (char*)utf8_hop((U8*)m, len);
5896                 else
5897                     s = m + len; /* Fake \n at the end */
5898             }
5899         }
5900         else {
5901 #ifndef lint
5902             while (s < strend && --limit &&
5903               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5904                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5905 #endif
5906             {
5907                 dstr = NEWSV(31, m-s);
5908                 sv_setpvn(dstr, s, m-s);
5909                 if (make_mortal)
5910                     sv_2mortal(dstr);
5911                 if (do_utf8)
5912                     (void)SvUTF8_on(dstr);
5913                 XPUSHs(dstr);
5914                 /* The rx->minlen is in characters but we want to step
5915                  * s ahead by bytes. */
5916                 if (do_utf8)
5917                     s = (char*)utf8_hop((U8*)m, len);
5918                 else
5919                     s = m + len; /* Fake \n at the end */
5920             }
5921         }
5922     }
5923     else {
5924         maxiters += slen * rx->nparens;
5925         while (s < strend && --limit
5926 /*             && (!rx->check_substr
5927                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5928                                                  0, NULL))))
5929 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5930                               1 /* minend */, sv, NULL, 0))
5931         {
5932             TAINT_IF(RX_MATCH_TAINTED(rx));
5933             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5934                 m = s;
5935                 s = orig;
5936                 orig = rx->subbeg;
5937                 s = orig + (m - s);
5938                 strend = s + (strend - m);
5939             }
5940             m = rx->startp[0] + orig;
5941             dstr = NEWSV(32, m-s);
5942             sv_setpvn(dstr, s, m-s);
5943             if (make_mortal)
5944                 sv_2mortal(dstr);
5945             if (do_utf8)
5946                 (void)SvUTF8_on(dstr);
5947             XPUSHs(dstr);
5948             if (rx->nparens) {
5949                 for (i = 1; i <= rx->nparens; i++) {
5950                     s = rx->startp[i] + orig;
5951                     m = rx->endp[i] + orig;
5952                     if (m && s) {
5953                         dstr = NEWSV(33, m-s);
5954                         sv_setpvn(dstr, s, m-s);
5955                     }
5956                     else
5957                         dstr = NEWSV(33, 0);
5958                     if (make_mortal)
5959                         sv_2mortal(dstr);
5960                     if (do_utf8)
5961                         (void)SvUTF8_on(dstr);
5962                     XPUSHs(dstr);
5963                 }
5964             }
5965             s = rx->endp[0] + orig;
5966         }
5967     }
5968
5969     LEAVE_SCOPE(oldsave);
5970     iters = (SP - PL_stack_base) - base;
5971     if (iters > maxiters)
5972         DIE(aTHX_ "Split loop");
5973
5974     /* keep field after final delim? */
5975     if (s < strend || (iters && origlimit)) {
5976         STRLEN l = strend - s;
5977         dstr = NEWSV(34, l);
5978         sv_setpvn(dstr, s, l);
5979         if (make_mortal)
5980             sv_2mortal(dstr);
5981         if (do_utf8)
5982             (void)SvUTF8_on(dstr);
5983         XPUSHs(dstr);
5984         iters++;
5985     }
5986     else if (!origlimit) {
5987         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5988             iters--, SP--;
5989     }
5990
5991     if (realarray) {
5992         if (!mg) {
5993             SWITCHSTACK(ary, oldstack);
5994             if (SvSMAGICAL(ary)) {
5995                 PUTBACK;
5996                 mg_set((SV*)ary);
5997                 SPAGAIN;
5998             }
5999             if (gimme == G_ARRAY) {
6000                 EXTEND(SP, iters);
6001                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6002                 SP += iters;
6003                 RETURN;
6004             }
6005         }
6006         else {
6007             PUTBACK;
6008             ENTER;
6009             call_method("PUSH",G_SCALAR|G_DISCARD);
6010             LEAVE;
6011             SPAGAIN;
6012             if (gimme == G_ARRAY) {
6013                 /* EXTEND should not be needed - we just popped them */
6014                 EXTEND(SP, iters);
6015                 for (i=0; i < iters; i++) {
6016                     SV **svp = av_fetch(ary, i, FALSE);
6017                     PUSHs((svp) ? *svp : &PL_sv_undef);
6018                 }
6019                 RETURN;
6020             }
6021         }
6022     }
6023     else {
6024         if (gimme == G_ARRAY)
6025             RETURN;
6026     }
6027     if (iters || !pm->op_pmreplroot) {
6028         GETTARGET;
6029         PUSHi(iters);
6030         RETURN;
6031     }
6032     RETPUSHUNDEF;
6033 }
6034
6035 #ifdef USE_THREADS
6036 void
6037 Perl_unlock_condpair(pTHX_ void *svv)
6038 {
6039     MAGIC *mg = mg_find((SV*)svv, 'm');
6040
6041     if (!mg)
6042         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6043     MUTEX_LOCK(MgMUTEXP(mg));
6044     if (MgOWNER(mg) != thr)
6045         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6046     MgOWNER(mg) = 0;
6047     COND_SIGNAL(MgOWNERCONDP(mg));
6048     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6049                           PTR2UV(thr), PTR2UV(svv));)
6050     MUTEX_UNLOCK(MgMUTEXP(mg));
6051 }
6052 #endif /* USE_THREADS */
6053
6054 PP(pp_lock)
6055 {
6056     dSP;
6057     dTOPss;
6058     SV *retsv = sv;
6059 #ifdef USE_THREADS
6060     sv_lock(sv);
6061 #endif /* USE_THREADS */
6062     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6063         || SvTYPE(retsv) == SVt_PVCV) {
6064         retsv = refto(retsv);
6065     }
6066     SETs(retsv);
6067     RETURN;
6068 }
6069
6070 PP(pp_threadsv)
6071 {
6072 #ifdef USE_THREADS
6073     dSP;
6074     EXTEND(SP, 1);
6075     if (PL_op->op_private & OPpLVAL_INTRO)
6076         PUSHs(*save_threadsv(PL_op->op_targ));
6077     else
6078         PUSHs(THREADSV(PL_op->op_targ));
6079     RETURN;
6080 #else
6081     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6082 #endif /* USE_THREADS */
6083 }