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
1236         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1237             /* The parser saw this as a list repeat, and there
1238                are probably several items on the stack. But we're
1239                in scalar context, and there's no pp_list to save us
1240                now. So drop the rest of the items -- robin@kitsite.com
1241              */
1242             dMARK;
1243             SP = MARK;
1244         }
1245         PUSHTARG;
1246     }
1247     RETURN;
1248   }
1249 }
1250
1251 PP(pp_subtract)
1252 {
1253     dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1254     useleft = USE_LEFT(TOPm1s);
1255 #ifdef PERL_PRESERVE_IVUV
1256     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1257        "bad things" happen if you rely on signed integers wrapping.  */
1258     SvIV_please(TOPs);
1259     if (SvIOK(TOPs)) {
1260         /* Unless the left argument is integer in range we are going to have to
1261            use NV maths. Hence only attempt to coerce the right argument if
1262            we know the left is integer.  */
1263         register UV auv;
1264         bool auvok;
1265         bool a_valid = 0;
1266
1267         if (!useleft) {
1268             auv = 0;
1269             a_valid = auvok = 1;
1270             /* left operand is undef, treat as zero.  */
1271         } else {
1272             /* Left operand is defined, so is it IV? */
1273             SvIV_please(TOPm1s);
1274             if (SvIOK(TOPm1s)) {
1275                 if ((auvok = SvUOK(TOPm1s)))
1276                     auv = SvUVX(TOPm1s);
1277                 else {
1278                     register IV aiv = SvIVX(TOPm1s);
1279                     if (aiv >= 0) {
1280                         auv = aiv;
1281                         auvok = 1;      /* Now acting as a sign flag.  */
1282                     } else { /* 2s complement assumption for IV_MIN */
1283                         auv = (UV)-aiv;
1284                     }
1285                 }
1286                 a_valid = 1;
1287             }
1288         }
1289         if (a_valid) {
1290             bool result_good = 0;
1291             UV result;
1292             register UV buv;
1293             bool buvok = SvUOK(TOPs);
1294
1295             if (buvok)
1296                 buv = SvUVX(TOPs);
1297             else {
1298                 register IV biv = SvIVX(TOPs);
1299                 if (biv >= 0) {
1300                     buv = biv;
1301                     buvok = 1;
1302                 } else
1303                     buv = (UV)-biv;
1304             }
1305             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1306                else "IV" now, independant of how it came in.
1307                if a, b represents positive, A, B negative, a maps to -A etc
1308                a - b =>  (a - b)
1309                A - b => -(a + b)
1310                a - B =>  (a + b)
1311                A - B => -(a - b)
1312                all UV maths. negate result if A negative.
1313                subtract if signs same, add if signs differ. */
1314
1315             if (auvok ^ buvok) {
1316                 /* Signs differ.  */
1317                 result = auv + buv;
1318                 if (result >= auv)
1319                     result_good = 1;
1320             } else {
1321                 /* Signs same */
1322                 if (auv >= buv) {
1323                     result = auv - buv;
1324                     /* Must get smaller */
1325                     if (result <= auv)
1326                         result_good = 1;
1327                 } else {
1328                     result = buv - auv;
1329                     if (result <= buv) {
1330                         /* result really should be -(auv-buv). as its negation
1331                            of true value, need to swap our result flag  */
1332                         auvok = !auvok;
1333                         result_good = 1;
1334                     }
1335                 }
1336             }
1337             if (result_good) {
1338                 SP--;
1339                 if (auvok)
1340                     SETu( result );
1341                 else {
1342                     /* Negate result */
1343                     if (result <= (UV)IV_MIN)
1344                         SETi( -(IV)result );
1345                     else {
1346                         /* result valid, but out of range for IV.  */
1347                         SETn( -(NV)result );
1348                     }
1349                 }
1350                 RETURN;
1351             } /* Overflow, drop through to NVs.  */
1352         }
1353     }
1354 #endif
1355     useleft = USE_LEFT(TOPm1s);
1356     {
1357         dPOPnv;
1358         if (!useleft) {
1359             /* left operand is undef, treat as zero - value */
1360             SETn(-value);
1361             RETURN;
1362         }
1363         SETn( TOPn - value );
1364         RETURN;
1365     }
1366 }
1367
1368 PP(pp_left_shift)
1369 {
1370     dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1371     {
1372       IV shift = POPi;
1373       if (PL_op->op_private & HINT_INTEGER) {
1374         IV i = TOPi;
1375         SETi(i << shift);
1376       }
1377       else {
1378         UV u = TOPu;
1379         SETu(u << shift);
1380       }
1381       RETURN;
1382     }
1383 }
1384
1385 PP(pp_right_shift)
1386 {
1387     dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1388     {
1389       IV shift = POPi;
1390       if (PL_op->op_private & HINT_INTEGER) {
1391         IV i = TOPi;
1392         SETi(i >> shift);
1393       }
1394       else {
1395         UV u = TOPu;
1396         SETu(u >> shift);
1397       }
1398       RETURN;
1399     }
1400 }
1401
1402 PP(pp_lt)
1403 {
1404     dSP; tryAMAGICbinSET(lt,0);
1405 #ifdef PERL_PRESERVE_IVUV
1406     SvIV_please(TOPs);
1407     if (SvIOK(TOPs)) {
1408         SvIV_please(TOPm1s);
1409         if (SvIOK(TOPm1s)) {
1410             bool auvok = SvUOK(TOPm1s);
1411             bool buvok = SvUOK(TOPs);
1412
1413             if (!auvok && !buvok) { /* ## IV < IV ## */
1414                 IV aiv = SvIVX(TOPm1s);
1415                 IV biv = SvIVX(TOPs);
1416
1417                 SP--;
1418                 SETs(boolSV(aiv < biv));
1419                 RETURN;
1420             }
1421             if (auvok && buvok) { /* ## UV < UV ## */
1422                 UV auv = SvUVX(TOPm1s);
1423                 UV buv = SvUVX(TOPs);
1424
1425                 SP--;
1426                 SETs(boolSV(auv < buv));
1427                 RETURN;
1428             }
1429             if (auvok) { /* ## UV < IV ## */
1430                 UV auv;
1431                 IV biv;
1432
1433                 biv = SvIVX(TOPs);
1434                 SP--;
1435                 if (biv < 0) {
1436                     /* As (a) is a UV, it's >=0, so it cannot be < */
1437                     SETs(&PL_sv_no);
1438                     RETURN;
1439                 }
1440                 auv = SvUVX(TOPs);
1441                 if (auv >= (UV) IV_MAX) {
1442                     /* As (b) is an IV, it cannot be > IV_MAX */
1443                     SETs(&PL_sv_no);
1444                     RETURN;
1445                 }
1446                 SETs(boolSV(auv < (UV)biv));
1447                 RETURN;
1448             }
1449             { /* ## IV < UV ## */
1450                 IV aiv;
1451                 UV buv;
1452
1453                 aiv = SvIVX(TOPm1s);
1454                 if (aiv < 0) {
1455                     /* As (b) is a UV, it's >=0, so it must be < */
1456                     SP--;
1457                     SETs(&PL_sv_yes);
1458                     RETURN;
1459                 }
1460                 buv = SvUVX(TOPs);
1461                 SP--;
1462                 if (buv > (UV) IV_MAX) {
1463                     /* As (a) is an IV, it cannot be > IV_MAX */
1464                     SETs(&PL_sv_yes);
1465                     RETURN;
1466                 }
1467                 SETs(boolSV((UV)aiv < buv));
1468                 RETURN;
1469             }
1470         }
1471     }
1472 #endif
1473     {
1474       dPOPnv;
1475       SETs(boolSV(TOPn < value));
1476       RETURN;
1477     }
1478 }
1479
1480 PP(pp_gt)
1481 {
1482     dSP; tryAMAGICbinSET(gt,0);
1483 #ifdef PERL_PRESERVE_IVUV
1484     SvIV_please(TOPs);
1485     if (SvIOK(TOPs)) {
1486         SvIV_please(TOPm1s);
1487         if (SvIOK(TOPm1s)) {
1488             bool auvok = SvUOK(TOPm1s);
1489             bool buvok = SvUOK(TOPs);
1490
1491             if (!auvok && !buvok) { /* ## IV > IV ## */
1492                 IV aiv = SvIVX(TOPm1s);
1493                 IV biv = SvIVX(TOPs);
1494
1495                 SP--;
1496                 SETs(boolSV(aiv > biv));
1497                 RETURN;
1498             }
1499             if (auvok && buvok) { /* ## UV > UV ## */
1500                 UV auv = SvUVX(TOPm1s);
1501                 UV buv = SvUVX(TOPs);
1502
1503                 SP--;
1504                 SETs(boolSV(auv > buv));
1505                 RETURN;
1506             }
1507             if (auvok) { /* ## UV > IV ## */
1508                 UV auv;
1509                 IV biv;
1510
1511                 biv = SvIVX(TOPs);
1512                 SP--;
1513                 if (biv < 0) {
1514                     /* As (a) is a UV, it's >=0, so it must be > */
1515                     SETs(&PL_sv_yes);
1516                     RETURN;
1517                 }
1518                 auv = SvUVX(TOPs);
1519                 if (auv > (UV) IV_MAX) {
1520                     /* As (b) is an IV, it cannot be > IV_MAX */
1521                     SETs(&PL_sv_yes);
1522                     RETURN;
1523                 }
1524                 SETs(boolSV(auv > (UV)biv));
1525                 RETURN;
1526             }
1527             { /* ## IV > UV ## */
1528                 IV aiv;
1529                 UV buv;
1530
1531                 aiv = SvIVX(TOPm1s);
1532                 if (aiv < 0) {
1533                     /* As (b) is a UV, it's >=0, so it cannot be > */
1534                     SP--;
1535                     SETs(&PL_sv_no);
1536                     RETURN;
1537                 }
1538                 buv = SvUVX(TOPs);
1539                 SP--;
1540                 if (buv >= (UV) IV_MAX) {
1541                     /* As (a) is an IV, it cannot be > IV_MAX */
1542                     SETs(&PL_sv_no);
1543                     RETURN;
1544                 }
1545                 SETs(boolSV((UV)aiv > buv));
1546                 RETURN;
1547             }
1548         }
1549     }
1550 #endif
1551     {
1552       dPOPnv;
1553       SETs(boolSV(TOPn > value));
1554       RETURN;
1555     }
1556 }
1557
1558 PP(pp_le)
1559 {
1560     dSP; tryAMAGICbinSET(le,0);
1561 #ifdef PERL_PRESERVE_IVUV
1562     SvIV_please(TOPs);
1563     if (SvIOK(TOPs)) {
1564         SvIV_please(TOPm1s);
1565         if (SvIOK(TOPm1s)) {
1566             bool auvok = SvUOK(TOPm1s);
1567             bool buvok = SvUOK(TOPs);
1568
1569             if (!auvok && !buvok) { /* ## IV <= IV ## */
1570                 IV aiv = SvIVX(TOPm1s);
1571                 IV biv = SvIVX(TOPs);
1572
1573                 SP--;
1574                 SETs(boolSV(aiv <= biv));
1575                 RETURN;
1576             }
1577             if (auvok && buvok) { /* ## UV <= UV ## */
1578                 UV auv = SvUVX(TOPm1s);
1579                 UV buv = SvUVX(TOPs);
1580
1581                 SP--;
1582                 SETs(boolSV(auv <= buv));
1583                 RETURN;
1584             }
1585             if (auvok) { /* ## UV <= IV ## */
1586                 UV auv;
1587                 IV biv;
1588
1589                 biv = SvIVX(TOPs);
1590                 SP--;
1591                 if (biv < 0) {
1592                     /* As (a) is a UV, it's >=0, so a cannot be <= */
1593                     SETs(&PL_sv_no);
1594                     RETURN;
1595                 }
1596                 auv = SvUVX(TOPs);
1597                 if (auv > (UV) IV_MAX) {
1598                     /* As (b) is an IV, it cannot be > IV_MAX */
1599                     SETs(&PL_sv_no);
1600                     RETURN;
1601                 }
1602                 SETs(boolSV(auv <= (UV)biv));
1603                 RETURN;
1604             }
1605             { /* ## IV <= UV ## */
1606                 IV aiv;
1607                 UV buv;
1608
1609                 aiv = SvIVX(TOPm1s);
1610                 if (aiv < 0) {
1611                     /* As (b) is a UV, it's >=0, so a must be <= */
1612                     SP--;
1613                     SETs(&PL_sv_yes);
1614                     RETURN;
1615                 }
1616                 buv = SvUVX(TOPs);
1617                 SP--;
1618                 if (buv >= (UV) IV_MAX) {
1619                     /* As (a) is an IV, it cannot be > IV_MAX */
1620                     SETs(&PL_sv_yes);
1621                     RETURN;
1622                 }
1623                 SETs(boolSV((UV)aiv <= buv));
1624                 RETURN;
1625             }
1626         }
1627     }
1628 #endif
1629     {
1630       dPOPnv;
1631       SETs(boolSV(TOPn <= value));
1632       RETURN;
1633     }
1634 }
1635
1636 PP(pp_ge)
1637 {
1638     dSP; tryAMAGICbinSET(ge,0);
1639 #ifdef PERL_PRESERVE_IVUV
1640     SvIV_please(TOPs);
1641     if (SvIOK(TOPs)) {
1642         SvIV_please(TOPm1s);
1643         if (SvIOK(TOPm1s)) {
1644             bool auvok = SvUOK(TOPm1s);
1645             bool buvok = SvUOK(TOPs);
1646
1647             if (!auvok && !buvok) { /* ## IV >= IV ## */
1648                 IV aiv = SvIVX(TOPm1s);
1649                 IV biv = SvIVX(TOPs);
1650
1651                 SP--;
1652                 SETs(boolSV(aiv >= biv));
1653                 RETURN;
1654             }
1655             if (auvok && buvok) { /* ## UV >= UV ## */
1656                 UV auv = SvUVX(TOPm1s);
1657                 UV buv = SvUVX(TOPs);
1658
1659                 SP--;
1660                 SETs(boolSV(auv >= buv));
1661                 RETURN;
1662             }
1663             if (auvok) { /* ## UV >= IV ## */
1664                 UV auv;
1665                 IV biv;
1666
1667                 biv = SvIVX(TOPs);
1668                 SP--;
1669                 if (biv < 0) {
1670                     /* As (a) is a UV, it's >=0, so it must be >= */
1671                     SETs(&PL_sv_yes);
1672                     RETURN;
1673                 }
1674                 auv = SvUVX(TOPs);
1675                 if (auv >= (UV) IV_MAX) {
1676                     /* As (b) is an IV, it cannot be > IV_MAX */
1677                     SETs(&PL_sv_yes);
1678                     RETURN;
1679                 }
1680                 SETs(boolSV(auv >= (UV)biv));
1681                 RETURN;
1682             }
1683             { /* ## IV >= UV ## */
1684                 IV aiv;
1685                 UV buv;
1686
1687                 aiv = SvIVX(TOPm1s);
1688                 if (aiv < 0) {
1689                     /* As (b) is a UV, it's >=0, so a cannot be >= */
1690                     SP--;
1691                     SETs(&PL_sv_no);
1692                     RETURN;
1693                 }
1694                 buv = SvUVX(TOPs);
1695                 SP--;
1696                 if (buv > (UV) IV_MAX) {
1697                     /* As (a) is an IV, it cannot be > IV_MAX */
1698                     SETs(&PL_sv_no);
1699                     RETURN;
1700                 }
1701                 SETs(boolSV((UV)aiv >= buv));
1702                 RETURN;
1703             }
1704         }
1705     }
1706 #endif
1707     {
1708       dPOPnv;
1709       SETs(boolSV(TOPn >= value));
1710       RETURN;
1711     }
1712 }
1713
1714 PP(pp_ne)
1715 {
1716     dSP; tryAMAGICbinSET(ne,0);
1717 #ifndef NV_PRESERVES_UV
1718     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1719         SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1720         RETURN;
1721     }
1722 #endif
1723 #ifdef PERL_PRESERVE_IVUV
1724     SvIV_please(TOPs);
1725     if (SvIOK(TOPs)) {
1726         SvIV_please(TOPm1s);
1727         if (SvIOK(TOPm1s)) {
1728             bool auvok = SvUOK(TOPm1s);
1729             bool buvok = SvUOK(TOPs);
1730
1731             if (!auvok && !buvok) { /* ## IV <=> IV ## */
1732                 IV aiv = SvIVX(TOPm1s);
1733                 IV biv = SvIVX(TOPs);
1734
1735                 SP--;
1736                 SETs(boolSV(aiv != biv));
1737                 RETURN;
1738             }
1739             if (auvok && buvok) { /* ## UV != UV ## */
1740                 UV auv = SvUVX(TOPm1s);
1741                 UV buv = SvUVX(TOPs);
1742
1743                 SP--;
1744                 SETs(boolSV(auv != buv));
1745                 RETURN;
1746             }
1747             {                   /* ## Mixed IV,UV ## */
1748                 IV iv;
1749                 UV uv;
1750
1751                 /* != is commutative so swap if needed (save code) */
1752                 if (auvok) {
1753                     /* swap. top of stack (b) is the iv */
1754                     iv = SvIVX(TOPs);
1755                     SP--;
1756                     if (iv < 0) {
1757                         /* As (a) is a UV, it's >0, so it cannot be == */
1758                         SETs(&PL_sv_yes);
1759                         RETURN;
1760                     }
1761                     uv = SvUVX(TOPs);
1762                 } else {
1763                     iv = SvIVX(TOPm1s);
1764                     SP--;
1765                     if (iv < 0) {
1766                         /* As (b) is a UV, it's >0, so it cannot be == */
1767                         SETs(&PL_sv_yes);
1768                         RETURN;
1769                     }
1770                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1771                 }
1772                 /* we know iv is >= 0 */
1773                 if (uv > (UV) IV_MAX) {
1774                     SETs(&PL_sv_yes);
1775                     RETURN;
1776                 }
1777                 SETs(boolSV((UV)iv != uv));
1778                 RETURN;
1779             }
1780         }
1781     }
1782 #endif
1783     {
1784       dPOPnv;
1785       SETs(boolSV(TOPn != value));
1786       RETURN;
1787     }
1788 }
1789
1790 PP(pp_ncmp)
1791 {
1792     dSP; dTARGET; tryAMAGICbin(ncmp,0);
1793 #ifndef NV_PRESERVES_UV
1794     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1795         SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1796         RETURN;
1797     }
1798 #endif
1799 #ifdef PERL_PRESERVE_IVUV
1800     /* Fortunately it seems NaN isn't IOK */
1801     SvIV_please(TOPs);
1802     if (SvIOK(TOPs)) {
1803         SvIV_please(TOPm1s);
1804         if (SvIOK(TOPm1s)) {
1805             bool leftuvok = SvUOK(TOPm1s);
1806             bool rightuvok = SvUOK(TOPs);
1807             I32 value;
1808             if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1809                 IV leftiv = SvIVX(TOPm1s);
1810                 IV rightiv = SvIVX(TOPs);
1811
1812                 if (leftiv > rightiv)
1813                     value = 1;
1814                 else if (leftiv < rightiv)
1815                     value = -1;
1816                 else
1817                     value = 0;
1818             } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1819                 UV leftuv = SvUVX(TOPm1s);
1820                 UV rightuv = SvUVX(TOPs);
1821
1822                 if (leftuv > rightuv)
1823                     value = 1;
1824                 else if (leftuv < rightuv)
1825                     value = -1;
1826                 else
1827                     value = 0;
1828             } else if (leftuvok) { /* ## UV <=> IV ## */
1829                 UV leftuv;
1830                 IV rightiv;
1831
1832                 rightiv = SvIVX(TOPs);
1833                 if (rightiv < 0) {
1834                     /* As (a) is a UV, it's >=0, so it cannot be < */
1835                     value = 1;
1836                 } else {
1837                     leftuv = SvUVX(TOPm1s);
1838                     if (leftuv > (UV) IV_MAX) {
1839                         /* As (b) is an IV, it cannot be > IV_MAX */
1840                         value = 1;
1841                     } else if (leftuv > (UV)rightiv) {
1842                         value = 1;
1843                     } else if (leftuv < (UV)rightiv) {
1844                         value = -1;
1845                     } else {
1846                         value = 0;
1847                     }
1848                 }
1849             } else { /* ## IV <=> UV ## */
1850                 IV leftiv;
1851                 UV rightuv;
1852
1853                 leftiv = SvIVX(TOPm1s);
1854                 if (leftiv < 0) {
1855                     /* As (b) is a UV, it's >=0, so it must be < */
1856                     value = -1;
1857                 } else {
1858                     rightuv = SvUVX(TOPs);
1859                     if (rightuv > (UV) IV_MAX) {
1860                         /* As (a) is an IV, it cannot be > IV_MAX */
1861                         value = -1;
1862                     } else if (leftiv > (UV)rightuv) {
1863                         value = 1;
1864                     } else if (leftiv < (UV)rightuv) {
1865                         value = -1;
1866                     } else {
1867                         value = 0;
1868                     }
1869                 }
1870             }
1871             SP--;
1872             SETi(value);
1873             RETURN;
1874         }
1875     }
1876 #endif
1877     {
1878       dPOPTOPnnrl;
1879       I32 value;
1880
1881 #ifdef Perl_isnan
1882       if (Perl_isnan(left) || Perl_isnan(right)) {
1883           SETs(&PL_sv_undef);
1884           RETURN;
1885        }
1886       value = (left > right) - (left < right);
1887 #else
1888       if (left == right)
1889         value = 0;
1890       else if (left < right)
1891         value = -1;
1892       else if (left > right)
1893         value = 1;
1894       else {
1895         SETs(&PL_sv_undef);
1896         RETURN;
1897       }
1898 #endif
1899       SETi(value);
1900       RETURN;
1901     }
1902 }
1903
1904 PP(pp_slt)
1905 {
1906     dSP; tryAMAGICbinSET(slt,0);
1907     {
1908       dPOPTOPssrl;
1909       int cmp = ((PL_op->op_private & OPpLOCALE)
1910                  ? sv_cmp_locale(left, right)
1911                  : sv_cmp(left, right));
1912       SETs(boolSV(cmp < 0));
1913       RETURN;
1914     }
1915 }
1916
1917 PP(pp_sgt)
1918 {
1919     dSP; tryAMAGICbinSET(sgt,0);
1920     {
1921       dPOPTOPssrl;
1922       int cmp = ((PL_op->op_private & OPpLOCALE)
1923                  ? sv_cmp_locale(left, right)
1924                  : sv_cmp(left, right));
1925       SETs(boolSV(cmp > 0));
1926       RETURN;
1927     }
1928 }
1929
1930 PP(pp_sle)
1931 {
1932     dSP; tryAMAGICbinSET(sle,0);
1933     {
1934       dPOPTOPssrl;
1935       int cmp = ((PL_op->op_private & OPpLOCALE)
1936                  ? sv_cmp_locale(left, right)
1937                  : sv_cmp(left, right));
1938       SETs(boolSV(cmp <= 0));
1939       RETURN;
1940     }
1941 }
1942
1943 PP(pp_sge)
1944 {
1945     dSP; tryAMAGICbinSET(sge,0);
1946     {
1947       dPOPTOPssrl;
1948       int cmp = ((PL_op->op_private & OPpLOCALE)
1949                  ? sv_cmp_locale(left, right)
1950                  : sv_cmp(left, right));
1951       SETs(boolSV(cmp >= 0));
1952       RETURN;
1953     }
1954 }
1955
1956 PP(pp_seq)
1957 {
1958     dSP; tryAMAGICbinSET(seq,0);
1959     {
1960       dPOPTOPssrl;
1961       SETs(boolSV(sv_eq(left, right)));
1962       RETURN;
1963     }
1964 }
1965
1966 PP(pp_sne)
1967 {
1968     dSP; tryAMAGICbinSET(sne,0);
1969     {
1970       dPOPTOPssrl;
1971       SETs(boolSV(!sv_eq(left, right)));
1972       RETURN;
1973     }
1974 }
1975
1976 PP(pp_scmp)
1977 {
1978     dSP; dTARGET;  tryAMAGICbin(scmp,0);
1979 #ifndef NV_PRESERVES_UV
1980     if (SvROK(TOPs) && SvROK(TOPm1s)) {
1981         SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1982         RETURN;
1983     }
1984 #endif
1985     {
1986       dPOPTOPssrl;
1987       int cmp = ((PL_op->op_private & OPpLOCALE)
1988                  ? sv_cmp_locale(left, right)
1989                  : sv_cmp(left, right));
1990       SETi( cmp );
1991       RETURN;
1992     }
1993 }
1994
1995 PP(pp_bit_and)
1996 {
1997     dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1998     {
1999       dPOPTOPssrl;
2000       if (SvNIOKp(left) || SvNIOKp(right)) {
2001         if (PL_op->op_private & HINT_INTEGER) {
2002           IV i = SvIV(left) & SvIV(right);
2003           SETi(i);
2004         }
2005         else {
2006           UV u = SvUV(left) & SvUV(right);
2007           SETu(u);
2008         }
2009       }
2010       else {
2011         do_vop(PL_op->op_type, TARG, left, right);
2012         SETTARG;
2013       }
2014       RETURN;
2015     }
2016 }
2017
2018 PP(pp_bit_xor)
2019 {
2020     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2021     {
2022       dPOPTOPssrl;
2023       if (SvNIOKp(left) || SvNIOKp(right)) {
2024         if (PL_op->op_private & HINT_INTEGER) {
2025           IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2026           SETi(i);
2027         }
2028         else {
2029           UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2030           SETu(u);
2031         }
2032       }
2033       else {
2034         do_vop(PL_op->op_type, TARG, left, right);
2035         SETTARG;
2036       }
2037       RETURN;
2038     }
2039 }
2040
2041 PP(pp_bit_or)
2042 {
2043     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2044     {
2045       dPOPTOPssrl;
2046       if (SvNIOKp(left) || SvNIOKp(right)) {
2047         if (PL_op->op_private & HINT_INTEGER) {
2048           IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2049           SETi(i);
2050         }
2051         else {
2052           UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2053           SETu(u);
2054         }
2055       }
2056       else {
2057         do_vop(PL_op->op_type, TARG, left, right);
2058         SETTARG;
2059       }
2060       RETURN;
2061     }
2062 }
2063
2064 PP(pp_negate)
2065 {
2066     dSP; dTARGET; tryAMAGICun(neg);
2067     {
2068         dTOPss;
2069         int flags = SvFLAGS(sv);
2070         if (SvGMAGICAL(sv))
2071             mg_get(sv);
2072         if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2073             /* It's publicly an integer, or privately an integer-not-float */
2074         oops_its_an_int:
2075             if (SvIsUV(sv)) {
2076                 if (SvIVX(sv) == IV_MIN) {
2077                     /* 2s complement assumption. */
2078                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2079                     RETURN;
2080                 }
2081                 else if (SvUVX(sv) <= IV_MAX) {
2082                     SETi(-SvIVX(sv));
2083                     RETURN;
2084                 }
2085             }
2086             else if (SvIVX(sv) != IV_MIN) {
2087                 SETi(-SvIVX(sv));
2088                 RETURN;
2089             }
2090 #ifdef PERL_PRESERVE_IVUV
2091             else {
2092                 SETu((UV)IV_MIN);
2093                 RETURN;
2094             }
2095 #endif
2096         }
2097         if (SvNIOKp(sv))
2098             SETn(-SvNV(sv));
2099         else if (SvPOKp(sv)) {
2100             STRLEN len;
2101             char *s = SvPV(sv, len);
2102             if (isIDFIRST(*s)) {
2103                 sv_setpvn(TARG, "-", 1);
2104                 sv_catsv(TARG, sv);
2105             }
2106             else if (*s == '+' || *s == '-') {
2107                 sv_setsv(TARG, sv);
2108                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2109             }
2110             else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2111                 sv_setpvn(TARG, "-", 1);
2112                 sv_catsv(TARG, sv);
2113             }
2114             else {
2115               SvIV_please(sv);
2116               if (SvIOK(sv))
2117                 goto oops_its_an_int;
2118               sv_setnv(TARG, -SvNV(sv));
2119             }
2120             SETTARG;
2121         }
2122         else
2123             SETn(-SvNV(sv));
2124     }
2125     RETURN;
2126 }
2127
2128 PP(pp_not)
2129 {
2130     dSP; tryAMAGICunSET(not);
2131     *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2132     return NORMAL;
2133 }
2134
2135 PP(pp_complement)
2136 {
2137     dSP; dTARGET; tryAMAGICun(compl);
2138     {
2139       dTOPss;
2140       if (SvNIOKp(sv)) {
2141         if (PL_op->op_private & HINT_INTEGER) {
2142           IV i = ~SvIV(sv);
2143           SETi(i);
2144         }
2145         else {
2146           UV u = ~SvUV(sv);
2147           SETu(u);
2148         }
2149       }
2150       else {
2151         register U8 *tmps;
2152         register I32 anum;
2153         STRLEN len;
2154
2155         SvSetSV(TARG, sv);
2156         tmps = (U8*)SvPV_force(TARG, len);
2157         anum = len;
2158         if (SvUTF8(TARG)) {
2159           /* Calculate exact length, let's not estimate. */
2160           STRLEN targlen = 0;
2161           U8 *result;
2162           U8 *send;
2163           STRLEN l;
2164           UV nchar = 0;
2165           UV nwide = 0;
2166
2167           send = tmps + len;
2168           while (tmps < send) {
2169             UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2170             tmps += UTF8SKIP(tmps);
2171             targlen += UNISKIP(~c);
2172             nchar++;
2173             if (c > 0xff)
2174                 nwide++;
2175           }
2176
2177           /* Now rewind strings and write them. */
2178           tmps -= len;
2179
2180           if (nwide) {
2181               Newz(0, result, targlen + 1, U8);
2182               while (tmps < send) {
2183                   UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2184                   tmps += UTF8SKIP(tmps);
2185                   result = uvchr_to_utf8(result, ~c);
2186               }
2187               *result = '\0';
2188               result -= targlen;
2189               sv_setpvn(TARG, (char*)result, targlen);
2190               SvUTF8_on(TARG);
2191           }
2192           else {
2193               Newz(0, result, nchar + 1, U8);
2194               while (tmps < send) {
2195                   U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2196                   tmps += UTF8SKIP(tmps);
2197                   *result++ = ~c;
2198               }
2199               *result = '\0';
2200               result -= nchar;
2201               sv_setpvn(TARG, (char*)result, nchar);
2202           }
2203           Safefree(result);
2204           SETs(TARG);
2205           RETURN;
2206         }
2207 #ifdef LIBERAL
2208         {
2209             register long *tmpl;
2210             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2211                 *tmps = ~*tmps;
2212             tmpl = (long*)tmps;
2213             for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2214                 *tmpl = ~*tmpl;
2215             tmps = (U8*)tmpl;
2216         }
2217 #endif
2218         for ( ; anum > 0; anum--, tmps++)
2219             *tmps = ~*tmps;
2220
2221         SETs(TARG);
2222       }
2223       RETURN;
2224     }
2225 }
2226
2227 /* integer versions of some of the above */
2228
2229 PP(pp_i_multiply)
2230 {
2231     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2232     {
2233       dPOPTOPiirl;
2234       SETi( left * right );
2235       RETURN;
2236     }
2237 }
2238
2239 PP(pp_i_divide)
2240 {
2241     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2242     {
2243       dPOPiv;
2244       if (value == 0)
2245         DIE(aTHX_ "Illegal division by zero");
2246       value = POPi / value;
2247       PUSHi( value );
2248       RETURN;
2249     }
2250 }
2251
2252 PP(pp_i_modulo)
2253 {
2254     dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2255     {
2256       dPOPTOPiirl;
2257       if (!right)
2258         DIE(aTHX_ "Illegal modulus zero");
2259       SETi( left % right );
2260       RETURN;
2261     }
2262 }
2263
2264 PP(pp_i_add)
2265 {
2266     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2267     {
2268       dPOPTOPiirl_ul;
2269       SETi( left + right );
2270       RETURN;
2271     }
2272 }
2273
2274 PP(pp_i_subtract)
2275 {
2276     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2277     {
2278       dPOPTOPiirl_ul;
2279       SETi( left - right );
2280       RETURN;
2281     }
2282 }
2283
2284 PP(pp_i_lt)
2285 {
2286     dSP; tryAMAGICbinSET(lt,0);
2287     {
2288       dPOPTOPiirl;
2289       SETs(boolSV(left < right));
2290       RETURN;
2291     }
2292 }
2293
2294 PP(pp_i_gt)
2295 {
2296     dSP; tryAMAGICbinSET(gt,0);
2297     {
2298       dPOPTOPiirl;
2299       SETs(boolSV(left > right));
2300       RETURN;
2301     }
2302 }
2303
2304 PP(pp_i_le)
2305 {
2306     dSP; tryAMAGICbinSET(le,0);
2307     {
2308       dPOPTOPiirl;
2309       SETs(boolSV(left <= right));
2310       RETURN;
2311     }
2312 }
2313
2314 PP(pp_i_ge)
2315 {
2316     dSP; tryAMAGICbinSET(ge,0);
2317     {
2318       dPOPTOPiirl;
2319       SETs(boolSV(left >= right));
2320       RETURN;
2321     }
2322 }
2323
2324 PP(pp_i_eq)
2325 {
2326     dSP; tryAMAGICbinSET(eq,0);
2327     {
2328       dPOPTOPiirl;
2329       SETs(boolSV(left == right));
2330       RETURN;
2331     }
2332 }
2333
2334 PP(pp_i_ne)
2335 {
2336     dSP; tryAMAGICbinSET(ne,0);
2337     {
2338       dPOPTOPiirl;
2339       SETs(boolSV(left != right));
2340       RETURN;
2341     }
2342 }
2343
2344 PP(pp_i_ncmp)
2345 {
2346     dSP; dTARGET; tryAMAGICbin(ncmp,0);
2347     {
2348       dPOPTOPiirl;
2349       I32 value;
2350
2351       if (left > right)
2352         value = 1;
2353       else if (left < right)
2354         value = -1;
2355       else
2356         value = 0;
2357       SETi(value);
2358       RETURN;
2359     }
2360 }
2361
2362 PP(pp_i_negate)
2363 {
2364     dSP; dTARGET; tryAMAGICun(neg);
2365     SETi(-TOPi);
2366     RETURN;
2367 }
2368
2369 /* High falutin' math. */
2370
2371 PP(pp_atan2)
2372 {
2373     dSP; dTARGET; tryAMAGICbin(atan2,0);
2374     {
2375       dPOPTOPnnrl;
2376       SETn(Perl_atan2(left, right));
2377       RETURN;
2378     }
2379 }
2380
2381 PP(pp_sin)
2382 {
2383     dSP; dTARGET; tryAMAGICun(sin);
2384     {
2385       NV value;
2386       value = POPn;
2387       value = Perl_sin(value);
2388       XPUSHn(value);
2389       RETURN;
2390     }
2391 }
2392
2393 PP(pp_cos)
2394 {
2395     dSP; dTARGET; tryAMAGICun(cos);
2396     {
2397       NV value;
2398       value = POPn;
2399       value = Perl_cos(value);
2400       XPUSHn(value);
2401       RETURN;
2402     }
2403 }
2404
2405 /* Support Configure command-line overrides for rand() functions.
2406    After 5.005, perhaps we should replace this by Configure support
2407    for drand48(), random(), or rand().  For 5.005, though, maintain
2408    compatibility by calling rand() but allow the user to override it.
2409    See INSTALL for details.  --Andy Dougherty  15 July 1998
2410 */
2411 /* Now it's after 5.005, and Configure supports drand48() and random(),
2412    in addition to rand().  So the overrides should not be needed any more.
2413    --Jarkko Hietaniemi  27 September 1998
2414  */
2415
2416 #ifndef HAS_DRAND48_PROTO
2417 extern double drand48 (void);
2418 #endif
2419
2420 PP(pp_rand)
2421 {
2422     dSP; dTARGET;
2423     NV value;
2424     if (MAXARG < 1)
2425         value = 1.0;
2426     else
2427         value = POPn;
2428     if (value == 0.0)
2429         value = 1.0;
2430     if (!PL_srand_called) {
2431         (void)seedDrand01((Rand_seed_t)seed());
2432         PL_srand_called = TRUE;
2433     }
2434     value *= Drand01();
2435     XPUSHn(value);
2436     RETURN;
2437 }
2438
2439 PP(pp_srand)
2440 {
2441     dSP;
2442     UV anum;
2443     if (MAXARG < 1)
2444         anum = seed();
2445     else
2446         anum = POPu;
2447     (void)seedDrand01((Rand_seed_t)anum);
2448     PL_srand_called = TRUE;
2449     EXTEND(SP, 1);
2450     RETPUSHYES;
2451 }
2452
2453 STATIC U32
2454 S_seed(pTHX)
2455 {
2456     /*
2457      * This is really just a quick hack which grabs various garbage
2458      * values.  It really should be a real hash algorithm which
2459      * spreads the effect of every input bit onto every output bit,
2460      * if someone who knows about such things would bother to write it.
2461      * Might be a good idea to add that function to CORE as well.
2462      * No numbers below come from careful analysis or anything here,
2463      * except they are primes and SEED_C1 > 1E6 to get a full-width
2464      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
2465      * probably be bigger too.
2466      */
2467 #if RANDBITS > 16
2468 #  define SEED_C1       1000003
2469 #define   SEED_C4       73819
2470 #else
2471 #  define SEED_C1       25747
2472 #define   SEED_C4       20639
2473 #endif
2474 #define   SEED_C2       3
2475 #define   SEED_C3       269
2476 #define   SEED_C5       26107
2477
2478 #ifndef PERL_NO_DEV_RANDOM
2479     int fd;
2480 #endif
2481     U32 u;
2482 #ifdef VMS
2483 #  include <starlet.h>
2484     /* when[] = (low 32 bits, high 32 bits) of time since epoch
2485      * in 100-ns units, typically incremented ever 10 ms.        */
2486     unsigned int when[2];
2487 #else
2488 #  ifdef HAS_GETTIMEOFDAY
2489     struct timeval when;
2490 #  else
2491     Time_t when;
2492 #  endif
2493 #endif
2494
2495 /* This test is an escape hatch, this symbol isn't set by Configure. */
2496 #ifndef PERL_NO_DEV_RANDOM
2497 #ifndef PERL_RANDOM_DEVICE
2498    /* /dev/random isn't used by default because reads from it will block
2499     * if there isn't enough entropy available.  You can compile with
2500     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2501     * is enough real entropy to fill the seed. */
2502 #  define PERL_RANDOM_DEVICE "/dev/urandom"
2503 #endif
2504     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2505     if (fd != -1) {
2506         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2507             u = 0;
2508         PerlLIO_close(fd);
2509         if (u)
2510             return u;
2511     }
2512 #endif
2513
2514 #ifdef VMS
2515     _ckvmssts(sys$gettim(when));
2516     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2517 #else
2518 #  ifdef HAS_GETTIMEOFDAY
2519     gettimeofday(&when,(struct timezone *) 0);
2520     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2521 #  else
2522     (void)time(&when);
2523     u = (U32)SEED_C1 * when;
2524 #  endif
2525 #endif
2526     u += SEED_C3 * (U32)PerlProc_getpid();
2527     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2528 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
2529     u += SEED_C5 * (U32)PTR2UV(&when);
2530 #endif
2531     return u;
2532 }
2533
2534 PP(pp_exp)
2535 {
2536     dSP; dTARGET; tryAMAGICun(exp);
2537     {
2538       NV value;
2539       value = POPn;
2540       value = Perl_exp(value);
2541       XPUSHn(value);
2542       RETURN;
2543     }
2544 }
2545
2546 PP(pp_log)
2547 {
2548     dSP; dTARGET; tryAMAGICun(log);
2549     {
2550       NV value;
2551       value = POPn;
2552       if (value <= 0.0) {
2553         SET_NUMERIC_STANDARD();
2554         DIE(aTHX_ "Can't take log of %g", value);
2555       }
2556       value = Perl_log(value);
2557       XPUSHn(value);
2558       RETURN;
2559     }
2560 }
2561
2562 PP(pp_sqrt)
2563 {
2564     dSP; dTARGET; tryAMAGICun(sqrt);
2565     {
2566       NV value;
2567       value = POPn;
2568       if (value < 0.0) {
2569         SET_NUMERIC_STANDARD();
2570         DIE(aTHX_ "Can't take sqrt of %g", value);
2571       }
2572       value = Perl_sqrt(value);
2573       XPUSHn(value);
2574       RETURN;
2575     }
2576 }
2577
2578 PP(pp_int)
2579 {
2580     dSP; dTARGET; tryAMAGICun(int);
2581     {
2582       NV value;
2583       IV iv = TOPi; /* attempt to convert to IV if possible. */
2584       /* XXX it's arguable that compiler casting to IV might be subtly
2585          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2586          else preferring IV has introduced a subtle behaviour change bug. OTOH
2587          relying on floating point to be accurate is a bug.  */
2588
2589       if (SvIOK(TOPs)) {
2590         if (SvIsUV(TOPs)) {
2591             UV uv = TOPu;
2592             SETu(uv);
2593         } else
2594             SETi(iv);
2595       } else {
2596           value = TOPn;
2597           if (value >= 0.0) {
2598               if (value < (NV)UV_MAX + 0.5) {
2599                   SETu(U_V(value));
2600               } else {
2601 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2602                   (void)Perl_modf(value, &value);
2603 #else
2604                   double tmp = (double)value;
2605                   (void)Perl_modf(tmp, &tmp);
2606                   value = (NV)tmp;
2607 #endif
2608                   SETn(value);
2609               }
2610           }
2611           else {
2612               if (value > (NV)IV_MIN - 0.5) {
2613                   SETi(I_V(value));
2614               } else {
2615 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2616                   (void)Perl_modf(-value, &value);
2617                   value = -value;
2618 #else
2619                   double tmp = (double)value;
2620                   (void)Perl_modf(-tmp, &tmp);
2621                   value = -(NV)tmp;
2622 #endif
2623                   SETn(value);
2624               }
2625           }
2626       }
2627     }
2628     RETURN;
2629 }
2630
2631 PP(pp_abs)
2632 {
2633     dSP; dTARGET; tryAMAGICun(abs);
2634     {
2635       /* This will cache the NV value if string isn't actually integer  */
2636       IV iv = TOPi;
2637
2638       if (SvIOK(TOPs)) {
2639         /* IVX is precise  */
2640         if (SvIsUV(TOPs)) {
2641           SETu(TOPu);   /* force it to be numeric only */
2642         } else {
2643           if (iv >= 0) {
2644             SETi(iv);
2645           } else {
2646             if (iv != IV_MIN) {
2647               SETi(-iv);
2648             } else {
2649               /* 2s complement assumption. Also, not really needed as
2650                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2651               SETu(IV_MIN);
2652             }
2653           }
2654         }
2655       } else{
2656         NV value = TOPn;
2657         if (value < 0.0)
2658           value = -value;
2659         SETn(value);
2660       }
2661     }
2662     RETURN;
2663 }
2664
2665 PP(pp_hex)
2666 {
2667     dSP; dTARGET;
2668     char *tmps;
2669     STRLEN argtype;
2670     STRLEN n_a;
2671
2672     tmps = POPpx;
2673     argtype = 1;                /* allow underscores */
2674     XPUSHn(scan_hex(tmps, 99, &argtype));
2675     RETURN;
2676 }
2677
2678 PP(pp_oct)
2679 {
2680     dSP; dTARGET;
2681     NV value;
2682     STRLEN argtype;
2683     char *tmps;
2684     STRLEN n_a;
2685
2686     tmps = POPpx;
2687     while (*tmps && isSPACE(*tmps))
2688         tmps++;
2689     if (*tmps == '0')
2690         tmps++;
2691     argtype = 1;                /* allow underscores */
2692     if (*tmps == 'x')
2693         value = scan_hex(++tmps, 99, &argtype);
2694     else if (*tmps == 'b')
2695         value = scan_bin(++tmps, 99, &argtype);
2696     else
2697         value = scan_oct(tmps, 99, &argtype);
2698     XPUSHn(value);
2699     RETURN;
2700 }
2701
2702 /* String stuff. */
2703
2704 PP(pp_length)
2705 {
2706     dSP; dTARGET;
2707     SV *sv = TOPs;
2708
2709     if (DO_UTF8(sv))
2710         SETi(sv_len_utf8(sv));
2711     else
2712         SETi(sv_len(sv));
2713     RETURN;
2714 }
2715
2716 PP(pp_substr)
2717 {
2718     dSP; dTARGET;
2719     SV *sv;
2720     I32 len;
2721     STRLEN curlen;
2722     STRLEN utf8_curlen;
2723     I32 pos;
2724     I32 rem;
2725     I32 fail;
2726     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2727     char *tmps;
2728     I32 arybase = PL_curcop->cop_arybase;
2729     SV *repl_sv = NULL;
2730     char *repl = 0;
2731     STRLEN repl_len;
2732     int num_args = PL_op->op_private & 7;
2733     bool repl_need_utf8_upgrade = FALSE;
2734     bool repl_is_utf8 = FALSE;
2735
2736     SvTAINTED_off(TARG);                        /* decontaminate */
2737     SvUTF8_off(TARG);                           /* decontaminate */
2738     if (num_args > 2) {
2739         if (num_args > 3) {
2740             repl_sv = POPs;
2741             repl = SvPV(repl_sv, repl_len);
2742             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2743         }
2744         len = POPi;
2745     }
2746     pos = POPi;
2747     sv = POPs;
2748     PUTBACK;
2749     if (repl_sv) {
2750         if (repl_is_utf8) {
2751             if (!DO_UTF8(sv))
2752                 sv_utf8_upgrade(sv);
2753         }
2754         else if (DO_UTF8(sv))
2755             repl_need_utf8_upgrade = TRUE;
2756     }
2757     tmps = SvPV(sv, curlen);
2758     if (DO_UTF8(sv)) {
2759         utf8_curlen = sv_len_utf8(sv);
2760         if (utf8_curlen == curlen)
2761             utf8_curlen = 0;
2762         else
2763             curlen = utf8_curlen;
2764     }
2765     else
2766         utf8_curlen = 0;
2767
2768     if (pos >= arybase) {
2769         pos -= arybase;
2770         rem = curlen-pos;
2771         fail = rem;
2772         if (num_args > 2) {
2773             if (len < 0) {
2774                 rem += len;
2775                 if (rem < 0)
2776                     rem = 0;
2777             }
2778             else if (rem > len)
2779                      rem = len;
2780         }
2781     }
2782     else {
2783         pos += curlen;
2784         if (num_args < 3)
2785             rem = curlen;
2786         else if (len >= 0) {
2787             rem = pos+len;
2788             if (rem > (I32)curlen)
2789                 rem = curlen;
2790         }
2791         else {
2792             rem = curlen+len;
2793             if (rem < pos)
2794                 rem = pos;
2795         }
2796         if (pos < 0)
2797             pos = 0;
2798         fail = rem;
2799         rem -= pos;
2800     }
2801     if (fail < 0) {
2802         if (lvalue || repl)
2803             Perl_croak(aTHX_ "substr outside of string");
2804         if (ckWARN(WARN_SUBSTR))
2805             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2806         RETPUSHUNDEF;
2807     }
2808     else {
2809         I32 upos = pos;
2810         I32 urem = rem;
2811         if (utf8_curlen)
2812             sv_pos_u2b(sv, &pos, &rem);
2813         tmps += pos;
2814         sv_setpvn(TARG, tmps, rem);
2815         if (utf8_curlen)
2816             SvUTF8_on(TARG);
2817         if (repl) {
2818             SV* repl_sv_copy = NULL;
2819
2820             if (repl_need_utf8_upgrade) {
2821                 repl_sv_copy = newSVsv(repl_sv);
2822                 sv_utf8_upgrade(repl_sv_copy);
2823                 repl = SvPV(repl_sv_copy, repl_len);
2824                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2825             }
2826             sv_insert(sv, pos, rem, repl, repl_len);
2827             if (repl_is_utf8)
2828                 SvUTF8_on(sv);
2829             if (repl_sv_copy)
2830                 SvREFCNT_dec(repl_sv_copy);
2831         }
2832         else if (lvalue) {              /* it's an lvalue! */
2833             if (!SvGMAGICAL(sv)) {
2834                 if (SvROK(sv)) {
2835                     STRLEN n_a;
2836                     SvPV_force(sv,n_a);
2837                     if (ckWARN(WARN_SUBSTR))
2838                         Perl_warner(aTHX_ WARN_SUBSTR,
2839                                 "Attempt to use reference as lvalue in substr");
2840                 }
2841                 if (SvOK(sv))           /* is it defined ? */
2842                     (void)SvPOK_only_UTF8(sv);
2843                 else
2844                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2845             }
2846
2847             if (SvTYPE(TARG) < SVt_PVLV) {
2848                 sv_upgrade(TARG, SVt_PVLV);
2849                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2850             }
2851
2852             LvTYPE(TARG) = 'x';
2853             if (LvTARG(TARG) != sv) {
2854                 if (LvTARG(TARG))
2855                     SvREFCNT_dec(LvTARG(TARG));
2856                 LvTARG(TARG) = SvREFCNT_inc(sv);
2857             }
2858             LvTARGOFF(TARG) = upos;
2859             LvTARGLEN(TARG) = urem;
2860         }
2861     }
2862     SPAGAIN;
2863     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2864     RETURN;
2865 }
2866
2867 PP(pp_vec)
2868 {
2869     dSP; dTARGET;
2870     register IV size   = POPi;
2871     register IV offset = POPi;
2872     register SV *src = POPs;
2873     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2874
2875     SvTAINTED_off(TARG);                /* decontaminate */
2876     if (lvalue) {                       /* it's an lvalue! */
2877         if (SvTYPE(TARG) < SVt_PVLV) {
2878             sv_upgrade(TARG, SVt_PVLV);
2879             sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2880         }
2881         LvTYPE(TARG) = 'v';
2882         if (LvTARG(TARG) != src) {
2883             if (LvTARG(TARG))
2884                 SvREFCNT_dec(LvTARG(TARG));
2885             LvTARG(TARG) = SvREFCNT_inc(src);
2886         }
2887         LvTARGOFF(TARG) = offset;
2888         LvTARGLEN(TARG) = size;
2889     }
2890
2891     sv_setuv(TARG, do_vecget(src, offset, size));
2892     PUSHs(TARG);
2893     RETURN;
2894 }
2895
2896 PP(pp_index)
2897 {
2898     dSP; dTARGET;
2899     SV *big;
2900     SV *little;
2901     I32 offset;
2902     I32 retval;
2903     char *tmps;
2904     char *tmps2;
2905     STRLEN biglen;
2906     I32 arybase = PL_curcop->cop_arybase;
2907
2908     if (MAXARG < 3)
2909         offset = 0;
2910     else
2911         offset = POPi - arybase;
2912     little = POPs;
2913     big = POPs;
2914     tmps = SvPV(big, biglen);
2915     if (offset > 0 && DO_UTF8(big))
2916         sv_pos_u2b(big, &offset, 0);
2917     if (offset < 0)
2918         offset = 0;
2919     else if (offset > biglen)
2920         offset = biglen;
2921     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2922       (unsigned char*)tmps + biglen, little, 0)))
2923         retval = -1;
2924     else
2925         retval = tmps2 - tmps;
2926     if (retval > 0 && DO_UTF8(big))
2927         sv_pos_b2u(big, &retval);
2928     PUSHi(retval + arybase);
2929     RETURN;
2930 }
2931
2932 PP(pp_rindex)
2933 {
2934     dSP; dTARGET;
2935     SV *big;
2936     SV *little;
2937     STRLEN blen;
2938     STRLEN llen;
2939     I32 offset;
2940     I32 retval;
2941     char *tmps;
2942     char *tmps2;
2943     I32 arybase = PL_curcop->cop_arybase;
2944
2945     if (MAXARG >= 3)
2946         offset = POPi;
2947     little = POPs;
2948     big = POPs;
2949     tmps2 = SvPV(little, llen);
2950     tmps = SvPV(big, blen);
2951     if (MAXARG < 3)
2952         offset = blen;
2953     else {
2954         if (offset > 0 && DO_UTF8(big))
2955             sv_pos_u2b(big, &offset, 0);
2956         offset = offset - arybase + llen;
2957     }
2958     if (offset < 0)
2959         offset = 0;
2960     else if (offset > blen)
2961         offset = blen;
2962     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2963                           tmps2, tmps2 + llen)))
2964         retval = -1;
2965     else
2966         retval = tmps2 - tmps;
2967     if (retval > 0 && DO_UTF8(big))
2968         sv_pos_b2u(big, &retval);
2969     PUSHi(retval + arybase);
2970     RETURN;
2971 }
2972
2973 PP(pp_sprintf)
2974 {
2975     dSP; dMARK; dORIGMARK; dTARGET;
2976     do_sprintf(TARG, SP-MARK, MARK+1);
2977     TAINT_IF(SvTAINTED(TARG));
2978     SP = ORIGMARK;
2979     PUSHTARG;
2980     RETURN;
2981 }
2982
2983 PP(pp_ord)
2984 {
2985     dSP; dTARGET;
2986     SV *argsv = POPs;
2987     STRLEN len;
2988     U8 *s = (U8*)SvPVx(argsv, len);
2989
2990     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2991     RETURN;
2992 }
2993
2994 PP(pp_chr)
2995 {
2996     dSP; dTARGET;
2997     char *tmps;
2998     UV value = POPu;
2999
3000     (void)SvUPGRADE(TARG,SVt_PV);
3001
3002     if (value > 255 && !IN_BYTE) {
3003         SvGROW(TARG, UNISKIP(value)+1);
3004         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3005         SvCUR_set(TARG, tmps - SvPVX(TARG));
3006         *tmps = '\0';
3007         (void)SvPOK_only(TARG);
3008         SvUTF8_on(TARG);
3009         XPUSHs(TARG);
3010         RETURN;
3011     }
3012
3013     SvGROW(TARG,2);
3014     SvCUR_set(TARG, 1);
3015     tmps = SvPVX(TARG);
3016     *tmps++ = value;
3017     *tmps = '\0';
3018     (void)SvPOK_only(TARG);
3019     XPUSHs(TARG);
3020     RETURN;
3021 }
3022
3023 PP(pp_crypt)
3024 {
3025     dSP; dTARGET; dPOPTOPssrl;
3026     STRLEN n_a;
3027 #ifdef HAS_CRYPT
3028     char *tmps = SvPV(left, n_a);
3029 #ifdef FCRYPT
3030     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3031 #else
3032     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3033 #endif
3034 #else
3035     DIE(aTHX_
3036       "The crypt() function is unimplemented due to excessive paranoia.");
3037 #endif
3038     SETs(TARG);
3039     RETURN;
3040 }
3041
3042 PP(pp_ucfirst)
3043 {
3044     dSP;
3045     SV *sv = TOPs;
3046     register U8 *s;
3047     STRLEN slen;
3048
3049     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3050         STRLEN ulen;
3051         U8 tmpbuf[UTF8_MAXLEN+1];
3052         U8 *tend;
3053         UV uv;
3054
3055         if (PL_op->op_private & OPpLOCALE) {
3056             TAINT;
3057             SvTAINTED_on(sv);
3058             uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3059         }
3060         else
3061             uv = toTITLE_utf8(s);
3062
3063         tend = uvchr_to_utf8(tmpbuf, uv);
3064
3065         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3066             dTARGET;
3067             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3068             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3069             SvUTF8_on(TARG);
3070             SETs(TARG);
3071         }
3072         else {
3073             s = (U8*)SvPV_force(sv, slen);
3074             Copy(tmpbuf, s, ulen, U8);
3075         }
3076     }
3077     else {
3078         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3079             dTARGET;
3080             SvUTF8_off(TARG);                           /* decontaminate */
3081             sv_setsv(TARG, sv);
3082             sv = TARG;
3083             SETs(sv);
3084         }
3085         s = (U8*)SvPV_force(sv, slen);
3086         if (*s) {
3087             if (PL_op->op_private & OPpLOCALE) {
3088                 TAINT;
3089                 SvTAINTED_on(sv);
3090                 *s = toUPPER_LC(*s);
3091             }
3092             else
3093                 *s = toUPPER(*s);
3094         }
3095     }
3096     if (SvSMAGICAL(sv))
3097         mg_set(sv);
3098     RETURN;
3099 }
3100
3101 PP(pp_lcfirst)
3102 {
3103     dSP;
3104     SV *sv = TOPs;
3105     register U8 *s;
3106     STRLEN slen;
3107
3108     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3109         STRLEN ulen;
3110         U8 tmpbuf[UTF8_MAXLEN+1];
3111         U8 *tend;
3112         UV uv;
3113
3114         if (PL_op->op_private & OPpLOCALE) {
3115             TAINT;
3116             SvTAINTED_on(sv);
3117             uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3118         }
3119         else
3120             uv = toLOWER_utf8(s);
3121
3122         tend = uvchr_to_utf8(tmpbuf, uv);
3123
3124         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3125             dTARGET;
3126             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3127             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3128             SvUTF8_on(TARG);
3129             SETs(TARG);
3130         }
3131         else {
3132             s = (U8*)SvPV_force(sv, slen);
3133             Copy(tmpbuf, s, ulen, U8);
3134         }
3135     }
3136     else {
3137         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3138             dTARGET;
3139             SvUTF8_off(TARG);                           /* decontaminate */
3140             sv_setsv(TARG, sv);
3141             sv = TARG;
3142             SETs(sv);
3143         }
3144         s = (U8*)SvPV_force(sv, slen);
3145         if (*s) {
3146             if (PL_op->op_private & OPpLOCALE) {
3147                 TAINT;
3148                 SvTAINTED_on(sv);
3149                 *s = toLOWER_LC(*s);
3150             }
3151             else
3152                 *s = toLOWER(*s);
3153         }
3154     }
3155     if (SvSMAGICAL(sv))
3156         mg_set(sv);
3157     RETURN;
3158 }
3159
3160 PP(pp_uc)
3161 {
3162     dSP;
3163     SV *sv = TOPs;
3164     register U8 *s;
3165     STRLEN len;
3166
3167     if (DO_UTF8(sv)) {
3168         dTARGET;
3169         STRLEN ulen;
3170         register U8 *d;
3171         U8 *send;
3172
3173         s = (U8*)SvPV(sv,len);
3174         if (!len) {
3175             SvUTF8_off(TARG);                           /* decontaminate */
3176             sv_setpvn(TARG, "", 0);
3177             SETs(TARG);
3178         }
3179         else {
3180             (void)SvUPGRADE(TARG, SVt_PV);
3181             SvGROW(TARG, (len * 2) + 1);
3182             (void)SvPOK_only(TARG);
3183             d = (U8*)SvPVX(TARG);
3184             send = s + len;
3185             if (PL_op->op_private & OPpLOCALE) {
3186                 TAINT;
3187                 SvTAINTED_on(TARG);
3188                 while (s < send) {
3189                     d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3190                     s += ulen;
3191                 }
3192             }
3193             else {
3194                 while (s < send) {
3195                     d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3196                     s += UTF8SKIP(s);
3197                 }
3198             }
3199             *d = '\0';
3200             SvUTF8_on(TARG);
3201             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3202             SETs(TARG);
3203         }
3204     }
3205     else {
3206         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3207             dTARGET;
3208             SvUTF8_off(TARG);                           /* decontaminate */
3209             sv_setsv(TARG, sv);
3210             sv = TARG;
3211             SETs(sv);
3212         }
3213         s = (U8*)SvPV_force(sv, len);
3214         if (len) {
3215             register U8 *send = s + len;
3216
3217             if (PL_op->op_private & OPpLOCALE) {
3218                 TAINT;
3219                 SvTAINTED_on(sv);
3220                 for (; s < send; s++)
3221                     *s = toUPPER_LC(*s);
3222             }
3223             else {
3224                 for (; s < send; s++)
3225                     *s = toUPPER(*s);
3226             }
3227         }
3228     }
3229     if (SvSMAGICAL(sv))
3230         mg_set(sv);
3231     RETURN;
3232 }
3233
3234 PP(pp_lc)
3235 {
3236     dSP;
3237     SV *sv = TOPs;
3238     register U8 *s;
3239     STRLEN len;
3240
3241     if (DO_UTF8(sv)) {
3242         dTARGET;
3243         STRLEN ulen;
3244         register U8 *d;
3245         U8 *send;
3246
3247         s = (U8*)SvPV(sv,len);
3248         if (!len) {
3249             SvUTF8_off(TARG);                           /* decontaminate */
3250             sv_setpvn(TARG, "", 0);
3251             SETs(TARG);
3252         }
3253         else {
3254             (void)SvUPGRADE(TARG, SVt_PV);
3255             SvGROW(TARG, (len * 2) + 1);
3256             (void)SvPOK_only(TARG);
3257             d = (U8*)SvPVX(TARG);
3258             send = s + len;
3259             if (PL_op->op_private & OPpLOCALE) {
3260                 TAINT;
3261                 SvTAINTED_on(TARG);
3262                 while (s < send) {
3263                     d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3264                     s += ulen;
3265                 }
3266             }
3267             else {
3268                 while (s < send) {
3269                     d = uvchr_to_utf8(d, toLOWER_utf8(s));
3270                     s += UTF8SKIP(s);
3271                 }
3272             }
3273             *d = '\0';
3274             SvUTF8_on(TARG);
3275             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3276             SETs(TARG);
3277         }
3278     }
3279     else {
3280         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3281             dTARGET;
3282             SvUTF8_off(TARG);                           /* decontaminate */
3283             sv_setsv(TARG, sv);
3284             sv = TARG;
3285             SETs(sv);
3286         }
3287
3288         s = (U8*)SvPV_force(sv, len);
3289         if (len) {
3290             register U8 *send = s + len;
3291
3292             if (PL_op->op_private & OPpLOCALE) {
3293                 TAINT;
3294                 SvTAINTED_on(sv);
3295                 for (; s < send; s++)
3296                     *s = toLOWER_LC(*s);
3297             }
3298             else {
3299                 for (; s < send; s++)
3300                     *s = toLOWER(*s);
3301             }
3302         }
3303     }
3304     if (SvSMAGICAL(sv))
3305         mg_set(sv);
3306     RETURN;
3307 }
3308
3309 PP(pp_quotemeta)
3310 {
3311     dSP; dTARGET;
3312     SV *sv = TOPs;
3313     STRLEN len;
3314     register char *s = SvPV(sv,len);
3315     register char *d;
3316
3317     SvUTF8_off(TARG);                           /* decontaminate */
3318     if (len) {
3319         (void)SvUPGRADE(TARG, SVt_PV);
3320         SvGROW(TARG, (len * 2) + 1);
3321         d = SvPVX(TARG);
3322         if (DO_UTF8(sv)) {
3323             while (len) {
3324                 if (UTF8_IS_CONTINUED(*s)) {
3325                     STRLEN ulen = UTF8SKIP(s);
3326                     if (ulen > len)
3327                         ulen = len;
3328                     len -= ulen;
3329                     while (ulen--)
3330                         *d++ = *s++;
3331                 }
3332                 else {
3333                     if (!isALNUM(*s))
3334                         *d++ = '\\';
3335                     *d++ = *s++;
3336                     len--;
3337                 }
3338             }
3339             SvUTF8_on(TARG);
3340         }
3341         else {
3342             while (len--) {
3343                 if (!isALNUM(*s))
3344                     *d++ = '\\';
3345                 *d++ = *s++;
3346             }
3347         }
3348         *d = '\0';
3349         SvCUR_set(TARG, d - SvPVX(TARG));
3350         (void)SvPOK_only_UTF8(TARG);
3351     }
3352     else
3353         sv_setpvn(TARG, s, len);
3354     SETs(TARG);
3355     if (SvSMAGICAL(TARG))
3356         mg_set(TARG);
3357     RETURN;
3358 }
3359
3360 /* Arrays. */
3361
3362 PP(pp_aslice)
3363 {
3364     dSP; dMARK; dORIGMARK;
3365     register SV** svp;
3366     register AV* av = (AV*)POPs;
3367     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3368     I32 arybase = PL_curcop->cop_arybase;
3369     I32 elem;
3370
3371     if (SvTYPE(av) == SVt_PVAV) {
3372         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3373             I32 max = -1;
3374             for (svp = MARK + 1; svp <= SP; svp++) {
3375                 elem = SvIVx(*svp);
3376                 if (elem > max)
3377                     max = elem;
3378             }
3379             if (max > AvMAX(av))
3380                 av_extend(av, max);
3381         }
3382         while (++MARK <= SP) {
3383             elem = SvIVx(*MARK);
3384
3385             if (elem > 0)
3386                 elem -= arybase;
3387             svp = av_fetch(av, elem, lval);
3388             if (lval) {
3389                 if (!svp || *svp == &PL_sv_undef)
3390                     DIE(aTHX_ PL_no_aelem, elem);
3391                 if (PL_op->op_private & OPpLVAL_INTRO)
3392                     save_aelem(av, elem, svp);
3393             }
3394             *MARK = svp ? *svp : &PL_sv_undef;
3395         }
3396     }
3397     if (GIMME != G_ARRAY) {
3398         MARK = ORIGMARK;
3399         *++MARK = *SP;
3400         SP = MARK;
3401     }
3402     RETURN;
3403 }
3404
3405 /* Associative arrays. */
3406
3407 PP(pp_each)
3408 {
3409     dSP;
3410     HV *hash = (HV*)POPs;
3411     HE *entry;
3412     I32 gimme = GIMME_V;
3413     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3414
3415     PUTBACK;
3416     /* might clobber stack_sp */
3417     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3418     SPAGAIN;
3419
3420     EXTEND(SP, 2);
3421     if (entry) {
3422         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3423         if (gimme == G_ARRAY) {
3424             SV *val;
3425             PUTBACK;
3426             /* might clobber stack_sp */
3427             val = realhv ?
3428                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3429             SPAGAIN;
3430             PUSHs(val);
3431         }
3432     }
3433     else if (gimme == G_SCALAR)
3434         RETPUSHUNDEF;
3435
3436     RETURN;
3437 }
3438
3439 PP(pp_values)
3440 {
3441     return do_kv();
3442 }
3443
3444 PP(pp_keys)
3445 {
3446     return do_kv();
3447 }
3448
3449 PP(pp_delete)
3450 {
3451     dSP;
3452     I32 gimme = GIMME_V;
3453     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3454     SV *sv;
3455     HV *hv;
3456
3457     if (PL_op->op_private & OPpSLICE) {
3458         dMARK; dORIGMARK;
3459         U32 hvtype;
3460         hv = (HV*)POPs;
3461         hvtype = SvTYPE(hv);
3462         if (hvtype == SVt_PVHV) {                       /* hash element */
3463             while (++MARK <= SP) {
3464                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3465                 *MARK = sv ? sv : &PL_sv_undef;
3466             }
3467         }
3468         else if (hvtype == SVt_PVAV) {
3469             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3470                 while (++MARK <= SP) {
3471                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3472                     *MARK = sv ? sv : &PL_sv_undef;
3473                 }
3474             }
3475             else {                                      /* pseudo-hash element */
3476                 while (++MARK <= SP) {
3477                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3478                     *MARK = sv ? sv : &PL_sv_undef;
3479                 }
3480             }
3481         }
3482         else
3483             DIE(aTHX_ "Not a HASH reference");
3484         if (discard)
3485             SP = ORIGMARK;
3486         else if (gimme == G_SCALAR) {
3487             MARK = ORIGMARK;
3488             *++MARK = *SP;
3489             SP = MARK;
3490         }
3491     }
3492     else {
3493         SV *keysv = POPs;
3494         hv = (HV*)POPs;
3495         if (SvTYPE(hv) == SVt_PVHV)
3496             sv = hv_delete_ent(hv, keysv, discard, 0);
3497         else if (SvTYPE(hv) == SVt_PVAV) {
3498             if (PL_op->op_flags & OPf_SPECIAL)
3499                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3500             else
3501                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3502         }
3503         else
3504             DIE(aTHX_ "Not a HASH reference");
3505         if (!sv)
3506             sv = &PL_sv_undef;
3507         if (!discard)
3508             PUSHs(sv);
3509     }
3510     RETURN;
3511 }
3512
3513 PP(pp_exists)
3514 {
3515     dSP;
3516     SV *tmpsv;
3517     HV *hv;
3518
3519     if (PL_op->op_private & OPpEXISTS_SUB) {
3520         GV *gv;
3521         CV *cv;
3522         SV *sv = POPs;
3523         cv = sv_2cv(sv, &hv, &gv, FALSE);
3524         if (cv)
3525             RETPUSHYES;
3526         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3527             RETPUSHYES;
3528         RETPUSHNO;
3529     }
3530     tmpsv = POPs;
3531     hv = (HV*)POPs;
3532     if (SvTYPE(hv) == SVt_PVHV) {
3533         if (hv_exists_ent(hv, tmpsv, 0))
3534             RETPUSHYES;
3535     }
3536     else if (SvTYPE(hv) == SVt_PVAV) {
3537         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3538             if (av_exists((AV*)hv, SvIV(tmpsv)))
3539                 RETPUSHYES;
3540         }
3541         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3542             RETPUSHYES;
3543     }
3544     else {
3545         DIE(aTHX_ "Not a HASH reference");
3546     }
3547     RETPUSHNO;
3548 }
3549
3550 PP(pp_hslice)
3551 {
3552     dSP; dMARK; dORIGMARK;
3553     register HV *hv = (HV*)POPs;
3554     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3555     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3556
3557     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3558         DIE(aTHX_ "Can't localize pseudo-hash element");
3559
3560     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3561         while (++MARK <= SP) {
3562             SV *keysv = *MARK;
3563             SV **svp;
3564             I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3565             if (realhv) {
3566                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3567                 svp = he ? &HeVAL(he) : 0;
3568             }
3569             else {
3570                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3571             }
3572             if (lval) {
3573                 if (!svp || *svp == &PL_sv_undef) {
3574                     STRLEN n_a;
3575                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3576                 }
3577                 if (PL_op->op_private & OPpLVAL_INTRO) {
3578                     if (preeminent)
3579                         save_helem(hv, keysv, svp);
3580                     else {
3581                         STRLEN keylen;
3582                         char *key = SvPV(keysv, keylen);
3583                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3584                     }
3585                 }
3586             }
3587             *MARK = svp ? *svp : &PL_sv_undef;
3588         }
3589     }
3590     if (GIMME != G_ARRAY) {
3591         MARK = ORIGMARK;
3592         *++MARK = *SP;
3593         SP = MARK;
3594     }
3595     RETURN;
3596 }
3597
3598 /* List operators. */
3599
3600 PP(pp_list)
3601 {
3602     dSP; dMARK;
3603     if (GIMME != G_ARRAY) {
3604         if (++MARK <= SP)
3605             *MARK = *SP;                /* unwanted list, return last item */
3606         else
3607             *MARK = &PL_sv_undef;
3608         SP = MARK;
3609     }
3610     RETURN;
3611 }
3612
3613 PP(pp_lslice)
3614 {
3615     dSP;
3616     SV **lastrelem = PL_stack_sp;
3617     SV **lastlelem = PL_stack_base + POPMARK;
3618     SV **firstlelem = PL_stack_base + POPMARK + 1;
3619     register SV **firstrelem = lastlelem + 1;
3620     I32 arybase = PL_curcop->cop_arybase;
3621     I32 lval = PL_op->op_flags & OPf_MOD;
3622     I32 is_something_there = lval;
3623
3624     register I32 max = lastrelem - lastlelem;
3625     register SV **lelem;
3626     register I32 ix;
3627
3628     if (GIMME != G_ARRAY) {
3629         ix = SvIVx(*lastlelem);
3630         if (ix < 0)
3631             ix += max;
3632         else
3633             ix -= arybase;
3634         if (ix < 0 || ix >= max)
3635             *firstlelem = &PL_sv_undef;
3636         else
3637             *firstlelem = firstrelem[ix];
3638         SP = firstlelem;
3639         RETURN;
3640     }
3641
3642     if (max == 0) {
3643         SP = firstlelem - 1;
3644         RETURN;
3645     }
3646
3647     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3648         ix = SvIVx(*lelem);
3649         if (ix < 0)
3650             ix += max;
3651         else
3652             ix -= arybase;
3653         if (ix < 0 || ix >= max)
3654             *lelem = &PL_sv_undef;
3655         else {
3656             is_something_there = TRUE;
3657             if (!(*lelem = firstrelem[ix]))
3658                 *lelem = &PL_sv_undef;
3659         }
3660     }
3661     if (is_something_there)
3662         SP = lastlelem;
3663     else
3664         SP = firstlelem - 1;
3665     RETURN;
3666 }
3667
3668 PP(pp_anonlist)
3669 {
3670     dSP; dMARK; dORIGMARK;
3671     I32 items = SP - MARK;
3672     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3673     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3674     XPUSHs(av);
3675     RETURN;
3676 }
3677
3678 PP(pp_anonhash)
3679 {
3680     dSP; dMARK; dORIGMARK;
3681     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3682
3683     while (MARK < SP) {
3684         SV* key = *++MARK;
3685         SV *val = NEWSV(46, 0);
3686         if (MARK < SP)
3687             sv_setsv(val, *++MARK);
3688         else if (ckWARN(WARN_MISC))
3689             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3690         (void)hv_store_ent(hv,key,val,0);
3691     }
3692     SP = ORIGMARK;
3693     XPUSHs((SV*)hv);
3694     RETURN;
3695 }
3696
3697 PP(pp_splice)
3698 {
3699     dSP; dMARK; dORIGMARK;
3700     register AV *ary = (AV*)*++MARK;
3701     register SV **src;
3702     register SV **dst;
3703     register I32 i;
3704     register I32 offset;
3705     register I32 length;
3706     I32 newlen;
3707     I32 after;
3708     I32 diff;
3709     SV **tmparyval = 0;
3710     MAGIC *mg;
3711
3712     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3713         *MARK-- = SvTIED_obj((SV*)ary, mg);
3714         PUSHMARK(MARK);
3715         PUTBACK;
3716         ENTER;
3717         call_method("SPLICE",GIMME_V);
3718         LEAVE;
3719         SPAGAIN;
3720         RETURN;
3721     }
3722
3723     SP++;
3724
3725     if (++MARK < SP) {
3726         offset = i = SvIVx(*MARK);
3727         if (offset < 0)
3728             offset += AvFILLp(ary) + 1;
3729         else
3730             offset -= PL_curcop->cop_arybase;
3731         if (offset < 0)
3732             DIE(aTHX_ PL_no_aelem, i);
3733         if (++MARK < SP) {
3734             length = SvIVx(*MARK++);
3735             if (length < 0) {
3736                 length += AvFILLp(ary) - offset + 1;
3737                 if (length < 0)
3738                     length = 0;
3739             }
3740         }
3741         else
3742             length = AvMAX(ary) + 1;            /* close enough to infinity */
3743     }
3744     else {
3745         offset = 0;
3746         length = AvMAX(ary) + 1;
3747     }
3748     if (offset > AvFILLp(ary) + 1)
3749         offset = AvFILLp(ary) + 1;
3750     after = AvFILLp(ary) + 1 - (offset + length);
3751     if (after < 0) {                            /* not that much array */
3752         length += after;                        /* offset+length now in array */
3753         after = 0;
3754         if (!AvALLOC(ary))
3755             av_extend(ary, 0);
3756     }
3757
3758     /* At this point, MARK .. SP-1 is our new LIST */
3759
3760     newlen = SP - MARK;
3761     diff = newlen - length;
3762     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3763         av_reify(ary);
3764
3765     if (diff < 0) {                             /* shrinking the area */
3766         if (newlen) {
3767             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3768             Copy(MARK, tmparyval, newlen, SV*);
3769         }
3770
3771         MARK = ORIGMARK + 1;
3772         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3773             MEXTEND(MARK, length);
3774             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3775             if (AvREAL(ary)) {
3776                 EXTEND_MORTAL(length);
3777                 for (i = length, dst = MARK; i; i--) {
3778                     sv_2mortal(*dst);   /* free them eventualy */
3779                     dst++;
3780                 }
3781             }
3782             MARK += length - 1;
3783         }
3784         else {
3785             *MARK = AvARRAY(ary)[offset+length-1];
3786             if (AvREAL(ary)) {
3787                 sv_2mortal(*MARK);
3788                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3789                     SvREFCNT_dec(*dst++);       /* free them now */
3790             }
3791         }
3792         AvFILLp(ary) += diff;
3793
3794         /* pull up or down? */
3795
3796         if (offset < after) {                   /* easier to pull up */
3797             if (offset) {                       /* esp. if nothing to pull */
3798                 src = &AvARRAY(ary)[offset-1];
3799                 dst = src - diff;               /* diff is negative */
3800                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3801                     *dst-- = *src--;
3802             }
3803             dst = AvARRAY(ary);
3804             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3805             AvMAX(ary) += diff;
3806         }
3807         else {
3808             if (after) {                        /* anything to pull down? */
3809                 src = AvARRAY(ary) + offset + length;
3810                 dst = src + diff;               /* diff is negative */
3811                 Move(src, dst, after, SV*);
3812             }
3813             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3814                                                 /* avoid later double free */
3815         }
3816         i = -diff;
3817         while (i)
3818             dst[--i] = &PL_sv_undef;
3819
3820         if (newlen) {
3821             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3822               newlen; newlen--) {
3823                 *dst = NEWSV(46, 0);
3824                 sv_setsv(*dst++, *src++);
3825             }
3826             Safefree(tmparyval);
3827         }
3828     }
3829     else {                                      /* no, expanding (or same) */
3830         if (length) {
3831             New(452, tmparyval, length, SV*);   /* so remember deletion */
3832             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3833         }
3834
3835         if (diff > 0) {                         /* expanding */
3836
3837             /* push up or down? */
3838
3839             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3840                 if (offset) {
3841                     src = AvARRAY(ary);
3842                     dst = src - diff;
3843                     Move(src, dst, offset, SV*);
3844                 }
3845                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3846                 AvMAX(ary) += diff;
3847                 AvFILLp(ary) += diff;
3848             }
3849             else {
3850                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3851                     av_extend(ary, AvFILLp(ary) + diff);
3852                 AvFILLp(ary) += diff;
3853
3854                 if (after) {
3855                     dst = AvARRAY(ary) + AvFILLp(ary);
3856                     src = dst - diff;
3857                     for (i = after; i; i--) {
3858                         *dst-- = *src--;
3859                     }
3860                 }
3861             }
3862         }
3863
3864         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3865             *dst = NEWSV(46, 0);
3866             sv_setsv(*dst++, *src++);
3867         }
3868         MARK = ORIGMARK + 1;
3869         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3870             if (length) {
3871                 Copy(tmparyval, MARK, length, SV*);
3872                 if (AvREAL(ary)) {
3873                     EXTEND_MORTAL(length);
3874                     for (i = length, dst = MARK; i; i--) {
3875                         sv_2mortal(*dst);       /* free them eventualy */
3876                         dst++;
3877                     }
3878                 }
3879                 Safefree(tmparyval);
3880             }
3881             MARK += length - 1;
3882         }
3883         else if (length--) {
3884             *MARK = tmparyval[length];
3885             if (AvREAL(ary)) {
3886                 sv_2mortal(*MARK);
3887                 while (length-- > 0)
3888                     SvREFCNT_dec(tmparyval[length]);
3889             }
3890             Safefree(tmparyval);
3891         }
3892         else
3893             *MARK = &PL_sv_undef;
3894     }
3895     SP = MARK;
3896     RETURN;
3897 }
3898
3899 PP(pp_push)
3900 {
3901     dSP; dMARK; dORIGMARK; dTARGET;
3902     register AV *ary = (AV*)*++MARK;
3903     register SV *sv = &PL_sv_undef;
3904     MAGIC *mg;
3905
3906     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3907         *MARK-- = SvTIED_obj((SV*)ary, mg);
3908         PUSHMARK(MARK);
3909         PUTBACK;
3910         ENTER;
3911         call_method("PUSH",G_SCALAR|G_DISCARD);
3912         LEAVE;
3913         SPAGAIN;
3914     }
3915     else {
3916         /* Why no pre-extend of ary here ? */
3917         for (++MARK; MARK <= SP; MARK++) {
3918             sv = NEWSV(51, 0);
3919             if (*MARK)
3920                 sv_setsv(sv, *MARK);
3921             av_push(ary, sv);
3922         }
3923     }
3924     SP = ORIGMARK;
3925     PUSHi( AvFILL(ary) + 1 );
3926     RETURN;
3927 }
3928
3929 PP(pp_pop)
3930 {
3931     dSP;
3932     AV *av = (AV*)POPs;
3933     SV *sv = av_pop(av);
3934     if (AvREAL(av))
3935         (void)sv_2mortal(sv);
3936     PUSHs(sv);
3937     RETURN;
3938 }
3939
3940 PP(pp_shift)
3941 {
3942     dSP;
3943     AV *av = (AV*)POPs;
3944     SV *sv = av_shift(av);
3945     EXTEND(SP, 1);
3946     if (!sv)
3947         RETPUSHUNDEF;
3948     if (AvREAL(av))
3949         (void)sv_2mortal(sv);
3950     PUSHs(sv);
3951     RETURN;
3952 }
3953
3954 PP(pp_unshift)
3955 {
3956     dSP; dMARK; dORIGMARK; dTARGET;
3957     register AV *ary = (AV*)*++MARK;
3958     register SV *sv;
3959     register I32 i = 0;
3960     MAGIC *mg;
3961
3962     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3963         *MARK-- = SvTIED_obj((SV*)ary, mg);
3964         PUSHMARK(MARK);
3965         PUTBACK;
3966         ENTER;
3967         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3968         LEAVE;
3969         SPAGAIN;
3970     }
3971     else {
3972         av_unshift(ary, SP - MARK);
3973         while (MARK < SP) {
3974             sv = NEWSV(27, 0);
3975             sv_setsv(sv, *++MARK);
3976             (void)av_store(ary, i++, sv);
3977         }
3978     }
3979     SP = ORIGMARK;
3980     PUSHi( AvFILL(ary) + 1 );
3981     RETURN;
3982 }
3983
3984 PP(pp_reverse)
3985 {
3986     dSP; dMARK;
3987     register SV *tmp;
3988     SV **oldsp = SP;
3989
3990     if (GIMME == G_ARRAY) {
3991         MARK++;
3992         while (MARK < SP) {
3993             tmp = *MARK;
3994             *MARK++ = *SP;
3995             *SP-- = tmp;
3996         }
3997         /* safe as long as stack cannot get extended in the above */
3998         SP = oldsp;
3999     }
4000     else {
4001         register char *up;
4002         register char *down;
4003         register I32 tmp;
4004         dTARGET;
4005         STRLEN len;
4006
4007         SvUTF8_off(TARG);                               /* decontaminate */
4008         if (SP - MARK > 1)
4009             do_join(TARG, &PL_sv_no, MARK, SP);
4010         else
4011             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4012         up = SvPV_force(TARG, len);
4013         if (len > 1) {
4014             if (DO_UTF8(TARG)) {        /* first reverse each character */
4015                 U8* s = (U8*)SvPVX(TARG);
4016                 U8* send = (U8*)(s + len);
4017                 while (s < send) {
4018                     if (UTF8_IS_INVARIANT(*s)) {
4019                         s++;
4020                         continue;
4021                     }
4022                     else {
4023                         if (!utf8_to_uvchr(s, 0))
4024                             break;
4025                         up = (char*)s;
4026                         s += UTF8SKIP(s);
4027                         down = (char*)(s - 1);
4028                         /* reverse this character */
4029                         while (down > up) {
4030                             tmp = *up;
4031                             *up++ = *down;
4032                             *down-- = tmp;
4033                         }
4034                     }
4035                 }
4036                 up = SvPVX(TARG);
4037             }
4038             down = SvPVX(TARG) + len - 1;
4039             while (down > up) {
4040                 tmp = *up;
4041                 *up++ = *down;
4042                 *down-- = tmp;
4043             }
4044             (void)SvPOK_only_UTF8(TARG);
4045         }
4046         SP = MARK + 1;
4047         SETTARG;
4048     }
4049     RETURN;
4050 }
4051
4052 STATIC SV *
4053 S_mul128(pTHX_ SV *sv, U8 m)
4054 {
4055   STRLEN          len;
4056   char           *s = SvPV(sv, len);
4057   char           *t;
4058   U32             i = 0;
4059
4060   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
4061     SV             *tmpNew = newSVpvn("0000000000", 10);
4062
4063     sv_catsv(tmpNew, sv);
4064     SvREFCNT_dec(sv);           /* free old sv */
4065     sv = tmpNew;
4066     s = SvPV(sv, len);
4067   }
4068   t = s + len - 1;
4069   while (!*t)                   /* trailing '\0'? */
4070     t--;
4071   while (t > s) {
4072     i = ((*t - '0') << 7) + m;
4073     *(t--) = '0' + (i % 10);
4074     m = i / 10;
4075   }
4076   return (sv);
4077 }
4078
4079 /* Explosives and implosives. */
4080
4081 #if 'I' == 73 && 'J' == 74
4082 /* On an ASCII/ISO kind of system */
4083 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
4084 #else
4085 /*
4086   Some other sort of character set - use memchr() so we don't match
4087   the null byte.
4088  */
4089 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4090 #endif
4091
4092
4093 PP(pp_unpack)
4094 {
4095     dSP;
4096     dPOPPOPssrl;
4097     I32 start_sp_offset = SP - PL_stack_base;
4098     I32 gimme = GIMME_V;
4099     SV *sv;
4100     STRLEN llen;
4101     STRLEN rlen;
4102     register char *pat = SvPV(left, llen);
4103 #ifdef PACKED_IS_OCTETS
4104     /* Packed side is assumed to be octets - so force downgrade if it
4105        has been UTF-8 encoded by accident
4106      */
4107     register char *s = SvPVbyte(right, rlen);
4108 #else
4109     register char *s = SvPV(right, rlen);
4110 #endif
4111     char *strend = s + rlen;
4112     char *strbeg = s;
4113     register char *patend = pat + llen;
4114     I32 datumtype;
4115     register I32 len;
4116     register I32 bits;
4117     register char *str;
4118
4119     /* These must not be in registers: */
4120     short ashort;
4121     int aint;
4122     long along;
4123 #ifdef HAS_QUAD
4124     Quad_t aquad;
4125 #endif
4126     U16 aushort;
4127     unsigned int auint;
4128     U32 aulong;
4129 #ifdef HAS_QUAD
4130     Uquad_t auquad;
4131 #endif
4132     char *aptr;
4133     float afloat;
4134     double adouble;
4135     I32 checksum = 0;
4136     register U32 culong;
4137     NV cdouble;
4138     int commas = 0;
4139     int star;
4140 #ifdef PERL_NATINT_PACK
4141     int natint;         /* native integer */
4142     int unatint;        /* unsigned native integer */
4143 #endif
4144
4145     if (gimme != G_ARRAY) {             /* arrange to do first one only */
4146         /*SUPPRESS 530*/
4147         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4148         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4149             patend++;
4150             while (isDIGIT(*patend) || *patend == '*')
4151                 patend++;
4152         }
4153         else
4154             patend++;
4155     }
4156     while (pat < patend) {
4157       reparse:
4158         datumtype = *pat++ & 0xFF;
4159 #ifdef PERL_NATINT_PACK
4160         natint = 0;
4161 #endif
4162         if (isSPACE(datumtype))
4163             continue;
4164         if (datumtype == '#') {
4165             while (pat < patend && *pat != '\n')
4166                 pat++;
4167             continue;
4168         }
4169         if (*pat == '!') {
4170             char *natstr = "sSiIlL";
4171
4172             if (strchr(natstr, datumtype)) {
4173 #ifdef PERL_NATINT_PACK
4174                 natint = 1;
4175 #endif
4176                 pat++;
4177             }
4178             else
4179                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4180         }
4181         star = 0;
4182         if (pat >= patend)
4183             len = 1;
4184         else if (*pat == '*') {
4185             len = strend - strbeg;      /* long enough */
4186             pat++;
4187             star = 1;
4188         }
4189         else if (isDIGIT(*pat)) {
4190             len = *pat++ - '0';
4191             while (isDIGIT(*pat)) {
4192                 len = (len * 10) + (*pat++ - '0');
4193                 if (len < 0)
4194                     DIE(aTHX_ "Repeat count in unpack overflows");
4195             }
4196         }
4197         else
4198             len = (datumtype != '@');
4199       redo_switch:
4200         switch(datumtype) {
4201         default:
4202             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4203         case ',': /* grandfather in commas but with a warning */
4204             if (commas++ == 0 && ckWARN(WARN_UNPACK))
4205                 Perl_warner(aTHX_ WARN_UNPACK,
4206                             "Invalid type in unpack: '%c'", (int)datumtype);
4207             break;
4208         case '%':
4209             if (len == 1 && pat[-1] != '1')
4210                 len = 16;
4211             checksum = len;
4212             culong = 0;
4213             cdouble = 0;
4214             if (pat < patend)
4215                 goto reparse;
4216             break;
4217         case '@':
4218             if (len > strend - strbeg)
4219                 DIE(aTHX_ "@ outside of string");
4220             s = strbeg + len;
4221             break;
4222         case 'X':
4223             if (len > s - strbeg)
4224                 DIE(aTHX_ "X outside of string");
4225             s -= len;
4226             break;
4227         case 'x':
4228             if (len > strend - s)
4229                 DIE(aTHX_ "x outside of string");
4230             s += len;
4231             break;
4232         case '/':
4233             if (start_sp_offset >= SP - PL_stack_base)
4234                 DIE(aTHX_ "/ must follow a numeric type");
4235             datumtype = *pat++;
4236             if (*pat == '*')
4237                 pat++;          /* ignore '*' for compatibility with pack */
4238             if (isDIGIT(*pat))
4239                 DIE(aTHX_ "/ cannot take a count" );
4240             len = POPi;
4241             star = 0;
4242             goto redo_switch;
4243         case 'A':
4244         case 'Z':
4245         case 'a':
4246             if (len > strend - s)
4247                 len = strend - s;
4248             if (checksum)
4249                 goto uchar_checksum;
4250             sv = NEWSV(35, len);
4251             sv_setpvn(sv, s, len);
4252             s += len;
4253             if (datumtype == 'A' || datumtype == 'Z') {
4254                 aptr = s;       /* borrow register */
4255                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4256                     s = SvPVX(sv);
4257                     while (*s)
4258                         s++;
4259                 }
4260                 else {          /* 'A' strips both nulls and spaces */
4261                     s = SvPVX(sv) + len - 1;
4262                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4263                         s--;
4264                     *++s = '\0';
4265                 }
4266                 SvCUR_set(sv, s - SvPVX(sv));
4267                 s = aptr;       /* unborrow register */
4268             }
4269             XPUSHs(sv_2mortal(sv));
4270             break;
4271         case 'B':
4272         case 'b':
4273             if (star || len > (strend - s) * 8)
4274                 len = (strend - s) * 8;
4275             if (checksum) {
4276                 if (!PL_bitcount) {
4277                     Newz(601, PL_bitcount, 256, char);
4278                     for (bits = 1; bits < 256; bits++) {
4279                         if (bits & 1)   PL_bitcount[bits]++;
4280                         if (bits & 2)   PL_bitcount[bits]++;
4281                         if (bits & 4)   PL_bitcount[bits]++;
4282                         if (bits & 8)   PL_bitcount[bits]++;
4283                         if (bits & 16)  PL_bitcount[bits]++;
4284                         if (bits & 32)  PL_bitcount[bits]++;
4285                         if (bits & 64)  PL_bitcount[bits]++;
4286                         if (bits & 128) PL_bitcount[bits]++;
4287                     }
4288                 }
4289                 while (len >= 8) {
4290                     culong += PL_bitcount[*(unsigned char*)s++];
4291                     len -= 8;
4292                 }
4293                 if (len) {
4294                     bits = *s;
4295                     if (datumtype == 'b') {
4296                         while (len-- > 0) {
4297                             if (bits & 1) culong++;
4298                             bits >>= 1;
4299                         }
4300                     }
4301                     else {
4302                         while (len-- > 0) {
4303                             if (bits & 128) culong++;
4304                             bits <<= 1;
4305                         }
4306                     }
4307                 }
4308                 break;
4309             }
4310             sv = NEWSV(35, len + 1);
4311             SvCUR_set(sv, len);
4312             SvPOK_on(sv);
4313             str = SvPVX(sv);
4314             if (datumtype == 'b') {
4315                 aint = len;
4316                 for (len = 0; len < aint; len++) {
4317                     if (len & 7)                /*SUPPRESS 595*/
4318                         bits >>= 1;
4319                     else
4320                         bits = *s++;
4321                     *str++ = '0' + (bits & 1);
4322                 }
4323             }
4324             else {
4325                 aint = len;
4326                 for (len = 0; len < aint; len++) {
4327                     if (len & 7)
4328                         bits <<= 1;
4329                     else
4330                         bits = *s++;
4331                     *str++ = '0' + ((bits & 128) != 0);
4332                 }
4333             }
4334             *str = '\0';
4335             XPUSHs(sv_2mortal(sv));
4336             break;
4337         case 'H':
4338         case 'h':
4339             if (star || len > (strend - s) * 2)
4340                 len = (strend - s) * 2;
4341             sv = NEWSV(35, len + 1);
4342             SvCUR_set(sv, len);
4343             SvPOK_on(sv);
4344             str = SvPVX(sv);
4345             if (datumtype == 'h') {
4346                 aint = len;
4347                 for (len = 0; len < aint; len++) {
4348                     if (len & 1)
4349                         bits >>= 4;
4350                     else
4351                         bits = *s++;
4352                     *str++ = PL_hexdigit[bits & 15];
4353                 }
4354             }
4355             else {
4356                 aint = len;
4357                 for (len = 0; len < aint; len++) {
4358                     if (len & 1)
4359                         bits <<= 4;
4360                     else
4361                         bits = *s++;
4362                     *str++ = PL_hexdigit[(bits >> 4) & 15];
4363                 }
4364             }
4365             *str = '\0';
4366             XPUSHs(sv_2mortal(sv));
4367             break;
4368         case 'c':
4369             if (len > strend - s)
4370                 len = strend - s;
4371             if (checksum) {
4372                 while (len-- > 0) {
4373                     aint = *s++;
4374                     if (aint >= 128)    /* fake up signed chars */
4375                         aint -= 256;
4376                     culong += aint;
4377                 }
4378             }
4379             else {
4380                 EXTEND(SP, len);
4381                 EXTEND_MORTAL(len);
4382                 while (len-- > 0) {
4383                     aint = *s++;
4384                     if (aint >= 128)    /* fake up signed chars */
4385                         aint -= 256;
4386                     sv = NEWSV(36, 0);
4387                     sv_setiv(sv, (IV)aint);
4388                     PUSHs(sv_2mortal(sv));
4389                 }
4390             }
4391             break;
4392         case 'C':
4393             if (len > strend - s)
4394                 len = strend - s;
4395             if (checksum) {
4396               uchar_checksum:
4397                 while (len-- > 0) {
4398                     auint = *s++ & 255;
4399                     culong += auint;
4400                 }
4401             }
4402             else {
4403                 EXTEND(SP, len);
4404                 EXTEND_MORTAL(len);
4405                 while (len-- > 0) {
4406                     auint = *s++ & 255;
4407                     sv = NEWSV(37, 0);
4408                     sv_setiv(sv, (IV)auint);
4409                     PUSHs(sv_2mortal(sv));
4410                 }
4411             }
4412             break;
4413         case 'U':
4414             if (len > strend - s)
4415                 len = strend - s;
4416             if (checksum) {
4417                 while (len-- > 0 && s < strend) {
4418                     STRLEN alen;
4419                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4420                     along = alen;
4421                     s += along;
4422                     if (checksum > 32)
4423                         cdouble += (NV)auint;
4424                     else
4425                         culong += auint;
4426                 }
4427             }
4428             else {
4429                 EXTEND(SP, len);
4430                 EXTEND_MORTAL(len);
4431                 while (len-- > 0 && s < strend) {
4432                     STRLEN alen;
4433                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4434                     along = alen;
4435                     s += along;
4436                     sv = NEWSV(37, 0);
4437                     sv_setuv(sv, (UV)auint);
4438                     PUSHs(sv_2mortal(sv));
4439                 }
4440             }
4441             break;
4442         case 's':
4443 #if SHORTSIZE == SIZE16
4444             along = (strend - s) / SIZE16;
4445 #else
4446             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4447 #endif
4448             if (len > along)
4449                 len = along;
4450             if (checksum) {
4451 #if SHORTSIZE != SIZE16
4452                 if (natint) {
4453                     short ashort;
4454                     while (len-- > 0) {
4455                         COPYNN(s, &ashort, sizeof(short));
4456                         s += sizeof(short);
4457                         culong += ashort;
4458
4459                     }
4460                 }
4461                 else
4462 #endif
4463                 {
4464                     while (len-- > 0) {
4465                         COPY16(s, &ashort);
4466 #if SHORTSIZE > SIZE16
4467                         if (ashort > 32767)
4468                           ashort -= 65536;
4469 #endif
4470                         s += SIZE16;
4471                         culong += ashort;
4472                     }
4473                 }
4474             }
4475             else {
4476                 EXTEND(SP, len);
4477                 EXTEND_MORTAL(len);
4478 #if SHORTSIZE != SIZE16
4479                 if (natint) {
4480                     short ashort;
4481                     while (len-- > 0) {
4482                         COPYNN(s, &ashort, sizeof(short));
4483                         s += sizeof(short);
4484                         sv = NEWSV(38, 0);
4485                         sv_setiv(sv, (IV)ashort);
4486                         PUSHs(sv_2mortal(sv));
4487                     }
4488                 }
4489                 else
4490 #endif
4491                 {
4492                     while (len-- > 0) {
4493                         COPY16(s, &ashort);
4494 #if SHORTSIZE > SIZE16
4495                         if (ashort > 32767)
4496                           ashort -= 65536;
4497 #endif
4498                         s += SIZE16;
4499                         sv = NEWSV(38, 0);
4500                         sv_setiv(sv, (IV)ashort);
4501                         PUSHs(sv_2mortal(sv));
4502                     }
4503                 }
4504             }
4505             break;
4506         case 'v':
4507         case 'n':
4508         case 'S':
4509 #if SHORTSIZE == SIZE16
4510             along = (strend - s) / SIZE16;
4511 #else
4512             unatint = natint && datumtype == 'S';
4513             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4514 #endif
4515             if (len > along)
4516                 len = along;
4517             if (checksum) {
4518 #if SHORTSIZE != SIZE16
4519                 if (unatint) {
4520                     unsigned short aushort;
4521                     while (len-- > 0) {
4522                         COPYNN(s, &aushort, sizeof(unsigned short));
4523                         s += sizeof(unsigned short);
4524                         culong += aushort;
4525                     }
4526                 }
4527                 else
4528 #endif
4529                 {
4530                     while (len-- > 0) {
4531                         COPY16(s, &aushort);
4532                         s += SIZE16;
4533 #ifdef HAS_NTOHS
4534                         if (datumtype == 'n')
4535                             aushort = PerlSock_ntohs(aushort);
4536 #endif
4537 #ifdef HAS_VTOHS
4538                         if (datumtype == 'v')
4539                             aushort = vtohs(aushort);
4540 #endif
4541                         culong += aushort;
4542                     }
4543                 }
4544             }
4545             else {
4546                 EXTEND(SP, len);
4547                 EXTEND_MORTAL(len);
4548 #if SHORTSIZE != SIZE16
4549                 if (unatint) {
4550                     unsigned short aushort;
4551                     while (len-- > 0) {
4552                         COPYNN(s, &aushort, sizeof(unsigned short));
4553                         s += sizeof(unsigned short);
4554                         sv = NEWSV(39, 0);
4555                         sv_setiv(sv, (UV)aushort);
4556                         PUSHs(sv_2mortal(sv));
4557                     }
4558                 }
4559                 else
4560 #endif
4561                 {
4562                     while (len-- > 0) {
4563                         COPY16(s, &aushort);
4564                         s += SIZE16;
4565                         sv = NEWSV(39, 0);
4566 #ifdef HAS_NTOHS
4567                         if (datumtype == 'n')
4568                             aushort = PerlSock_ntohs(aushort);
4569 #endif
4570 #ifdef HAS_VTOHS
4571                         if (datumtype == 'v')
4572                             aushort = vtohs(aushort);
4573 #endif
4574                         sv_setiv(sv, (UV)aushort);
4575                         PUSHs(sv_2mortal(sv));
4576                     }
4577                 }
4578             }
4579             break;
4580         case 'i':
4581             along = (strend - s) / sizeof(int);
4582             if (len > along)
4583                 len = along;
4584             if (checksum) {
4585                 while (len-- > 0) {
4586                     Copy(s, &aint, 1, int);
4587                     s += sizeof(int);
4588                     if (checksum > 32)
4589                         cdouble += (NV)aint;
4590                     else
4591                         culong += aint;
4592                 }
4593             }
4594             else {
4595                 EXTEND(SP, len);
4596                 EXTEND_MORTAL(len);
4597                 while (len-- > 0) {
4598                     Copy(s, &aint, 1, int);
4599                     s += sizeof(int);
4600                     sv = NEWSV(40, 0);
4601 #ifdef __osf__
4602                     /* Without the dummy below unpack("i", pack("i",-1))
4603                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4604                      * cc with optimization turned on.
4605                      *
4606                      * The bug was detected in
4607                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4608                      * with optimization (-O4) turned on.
4609                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4610                      * does not have this problem even with -O4.
4611                      *
4612                      * This bug was reported as DECC_BUGS 1431
4613                      * and tracked internally as GEM_BUGS 7775.
4614                      *
4615                      * The bug is fixed in
4616                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
4617                      * UNIX V4.0F support:   DEC C V5.9-006 or later
4618                      * UNIX V4.0E support:   DEC C V5.8-011 or later
4619                      * and also in DTK.
4620                      *
4621                      * See also few lines later for the same bug.
4622                      */
4623                     (aint) ?
4624                         sv_setiv(sv, (IV)aint) :
4625 #endif
4626                     sv_setiv(sv, (IV)aint);
4627                     PUSHs(sv_2mortal(sv));
4628                 }
4629             }
4630             break;
4631         case 'I':
4632             along = (strend - s) / sizeof(unsigned int);
4633             if (len > along)
4634                 len = along;
4635             if (checksum) {
4636                 while (len-- > 0) {
4637                     Copy(s, &auint, 1, unsigned int);
4638                     s += sizeof(unsigned int);
4639                     if (checksum > 32)
4640                         cdouble += (NV)auint;
4641                     else
4642                         culong += auint;
4643                 }
4644             }
4645             else {
4646                 EXTEND(SP, len);
4647                 EXTEND_MORTAL(len);
4648                 while (len-- > 0) {
4649                     Copy(s, &auint, 1, unsigned int);
4650                     s += sizeof(unsigned int);
4651                     sv = NEWSV(41, 0);
4652 #ifdef __osf__
4653                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4654                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4655                      * See details few lines earlier. */
4656                     (auint) ?
4657                         sv_setuv(sv, (UV)auint) :
4658 #endif
4659                     sv_setuv(sv, (UV)auint);
4660                     PUSHs(sv_2mortal(sv));
4661                 }
4662             }
4663             break;
4664         case 'l':
4665 #if LONGSIZE == SIZE32
4666             along = (strend - s) / SIZE32;
4667 #else
4668             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4669 #endif
4670             if (len > along)
4671                 len = along;
4672             if (checksum) {
4673 #if LONGSIZE != SIZE32
4674                 if (natint) {
4675                     while (len-- > 0) {
4676                         COPYNN(s, &along, sizeof(long));
4677                         s += sizeof(long);
4678                         if (checksum > 32)
4679                             cdouble += (NV)along;
4680                         else
4681                             culong += along;
4682                     }
4683                 }
4684                 else
4685 #endif
4686                 {
4687                     while (len-- > 0) {
4688 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4689                         I32 along;
4690 #endif
4691                         COPY32(s, &along);
4692 #if LONGSIZE > SIZE32
4693                         if (along > 2147483647)
4694                           along -= 4294967296;
4695 #endif
4696                         s += SIZE32;
4697                         if (checksum > 32)
4698                             cdouble += (NV)along;
4699                         else
4700                             culong += along;
4701                     }
4702                 }
4703             }
4704             else {
4705                 EXTEND(SP, len);
4706                 EXTEND_MORTAL(len);
4707 #if LONGSIZE != SIZE32
4708                 if (natint) {
4709                     while (len-- > 0) {
4710                         COPYNN(s, &along, sizeof(long));
4711                         s += sizeof(long);
4712                         sv = NEWSV(42, 0);
4713                         sv_setiv(sv, (IV)along);
4714                         PUSHs(sv_2mortal(sv));
4715                     }
4716                 }
4717                 else
4718 #endif
4719                 {
4720                     while (len-- > 0) {
4721 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4722                         I32 along;
4723 #endif
4724                         COPY32(s, &along);
4725 #if LONGSIZE > SIZE32
4726                         if (along > 2147483647)
4727                           along -= 4294967296;
4728 #endif
4729                         s += SIZE32;
4730                         sv = NEWSV(42, 0);
4731                         sv_setiv(sv, (IV)along);
4732                         PUSHs(sv_2mortal(sv));
4733                     }
4734                 }
4735             }
4736             break;
4737         case 'V':
4738         case 'N':
4739         case 'L':
4740 #if LONGSIZE == SIZE32
4741             along = (strend - s) / SIZE32;
4742 #else
4743             unatint = natint && datumtype == 'L';
4744             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4745 #endif
4746             if (len > along)
4747                 len = along;
4748             if (checksum) {
4749 #if LONGSIZE != SIZE32
4750                 if (unatint) {
4751                     unsigned long aulong;
4752                     while (len-- > 0) {
4753                         COPYNN(s, &aulong, sizeof(unsigned long));
4754                         s += sizeof(unsigned long);
4755                         if (checksum > 32)
4756                             cdouble += (NV)aulong;
4757                         else
4758                             culong += aulong;
4759                     }
4760                 }
4761                 else
4762 #endif
4763                 {
4764                     while (len-- > 0) {
4765                         COPY32(s, &aulong);
4766                         s += SIZE32;
4767 #ifdef HAS_NTOHL
4768                         if (datumtype == 'N')
4769                             aulong = PerlSock_ntohl(aulong);
4770 #endif
4771 #ifdef HAS_VTOHL
4772                         if (datumtype == 'V')
4773                             aulong = vtohl(aulong);
4774 #endif
4775                         if (checksum > 32)
4776                             cdouble += (NV)aulong;
4777                         else
4778                             culong += aulong;
4779                     }
4780                 }
4781             }
4782             else {
4783                 EXTEND(SP, len);
4784                 EXTEND_MORTAL(len);
4785 #if LONGSIZE != SIZE32
4786                 if (unatint) {
4787                     unsigned long aulong;
4788                     while (len-- > 0) {
4789                         COPYNN(s, &aulong, sizeof(unsigned long));
4790                         s += sizeof(unsigned long);
4791                         sv = NEWSV(43, 0);
4792                         sv_setuv(sv, (UV)aulong);
4793                         PUSHs(sv_2mortal(sv));
4794                     }
4795                 }
4796                 else
4797 #endif
4798                 {
4799                     while (len-- > 0) {
4800                         COPY32(s, &aulong);
4801                         s += SIZE32;
4802 #ifdef HAS_NTOHL
4803                         if (datumtype == 'N')
4804                             aulong = PerlSock_ntohl(aulong);
4805 #endif
4806 #ifdef HAS_VTOHL
4807                         if (datumtype == 'V')
4808                             aulong = vtohl(aulong);
4809 #endif
4810                         sv = NEWSV(43, 0);
4811                         sv_setuv(sv, (UV)aulong);
4812                         PUSHs(sv_2mortal(sv));
4813                     }
4814                 }
4815             }
4816             break;
4817         case 'p':
4818             along = (strend - s) / sizeof(char*);
4819             if (len > along)
4820                 len = along;
4821             EXTEND(SP, len);
4822             EXTEND_MORTAL(len);
4823             while (len-- > 0) {
4824                 if (sizeof(char*) > strend - s)
4825                     break;
4826                 else {
4827                     Copy(s, &aptr, 1, char*);
4828                     s += sizeof(char*);
4829                 }
4830                 sv = NEWSV(44, 0);
4831                 if (aptr)
4832                     sv_setpv(sv, aptr);
4833                 PUSHs(sv_2mortal(sv));
4834             }
4835             break;
4836         case 'w':
4837             EXTEND(SP, len);
4838             EXTEND_MORTAL(len);
4839             {
4840                 UV auv = 0;
4841                 U32 bytes = 0;
4842
4843                 while ((len > 0) && (s < strend)) {
4844                     auv = (auv << 7) | (*s & 0x7f);
4845                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4846                     if ((U8)(*s++) < 0x80) {
4847                         bytes = 0;
4848                         sv = NEWSV(40, 0);
4849                         sv_setuv(sv, auv);
4850                         PUSHs(sv_2mortal(sv));
4851                         len--;
4852                         auv = 0;
4853                     }
4854                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4855                         char *t;
4856                         STRLEN n_a;
4857
4858                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4859                         while (s < strend) {
4860                             sv = mul128(sv, *s & 0x7f);
4861                             if (!(*s++ & 0x80)) {
4862                                 bytes = 0;
4863                                 break;
4864                             }
4865                         }
4866                         t = SvPV(sv, n_a);
4867                         while (*t == '0')
4868                             t++;
4869                         sv_chop(sv, t);
4870                         PUSHs(sv_2mortal(sv));
4871                         len--;
4872                         auv = 0;
4873                     }
4874                 }
4875                 if ((s >= strend) && bytes)
4876                     DIE(aTHX_ "Unterminated compressed integer");
4877             }
4878             break;
4879         case 'P':
4880             EXTEND(SP, 1);
4881             if (sizeof(char*) > strend - s)
4882                 break;
4883             else {
4884                 Copy(s, &aptr, 1, char*);
4885                 s += sizeof(char*);
4886             }
4887             sv = NEWSV(44, 0);
4888             if (aptr)
4889                 sv_setpvn(sv, aptr, len);
4890             PUSHs(sv_2mortal(sv));
4891             break;
4892 #ifdef HAS_QUAD
4893         case 'q':
4894             along = (strend - s) / sizeof(Quad_t);
4895             if (len > along)
4896                 len = along;
4897             EXTEND(SP, len);
4898             EXTEND_MORTAL(len);
4899             while (len-- > 0) {
4900                 if (s + sizeof(Quad_t) > strend)
4901                     aquad = 0;
4902                 else {
4903                     Copy(s, &aquad, 1, Quad_t);
4904                     s += sizeof(Quad_t);
4905                 }
4906                 sv = NEWSV(42, 0);
4907                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4908                     sv_setiv(sv, (IV)aquad);
4909                 else
4910                     sv_setnv(sv, (NV)aquad);
4911                 PUSHs(sv_2mortal(sv));
4912             }
4913             break;
4914         case 'Q':
4915             along = (strend - s) / sizeof(Quad_t);
4916             if (len > along)
4917                 len = along;
4918             EXTEND(SP, len);
4919             EXTEND_MORTAL(len);
4920             while (len-- > 0) {
4921                 if (s + sizeof(Uquad_t) > strend)
4922                     auquad = 0;
4923                 else {
4924                     Copy(s, &auquad, 1, Uquad_t);
4925                     s += sizeof(Uquad_t);
4926                 }
4927                 sv = NEWSV(43, 0);
4928                 if (auquad <= UV_MAX)
4929                     sv_setuv(sv, (UV)auquad);
4930                 else
4931                     sv_setnv(sv, (NV)auquad);
4932                 PUSHs(sv_2mortal(sv));
4933             }
4934             break;
4935 #endif
4936         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4937         case 'f':
4938         case 'F':
4939             along = (strend - s) / sizeof(float);
4940             if (len > along)
4941                 len = along;
4942             if (checksum) {
4943                 while (len-- > 0) {
4944                     Copy(s, &afloat, 1, float);
4945                     s += sizeof(float);
4946                     cdouble += afloat;
4947                 }
4948             }
4949             else {
4950                 EXTEND(SP, len);
4951                 EXTEND_MORTAL(len);
4952                 while (len-- > 0) {
4953                     Copy(s, &afloat, 1, float);
4954                     s += sizeof(float);
4955                     sv = NEWSV(47, 0);
4956                     sv_setnv(sv, (NV)afloat);
4957                     PUSHs(sv_2mortal(sv));
4958                 }
4959             }
4960             break;
4961         case 'd':
4962         case 'D':
4963             along = (strend - s) / sizeof(double);
4964             if (len > along)
4965                 len = along;
4966             if (checksum) {
4967                 while (len-- > 0) {
4968                     Copy(s, &adouble, 1, double);
4969                     s += sizeof(double);
4970                     cdouble += adouble;
4971                 }
4972             }
4973             else {
4974                 EXTEND(SP, len);
4975                 EXTEND_MORTAL(len);
4976                 while (len-- > 0) {
4977                     Copy(s, &adouble, 1, double);
4978                     s += sizeof(double);
4979                     sv = NEWSV(48, 0);
4980                     sv_setnv(sv, (NV)adouble);
4981                     PUSHs(sv_2mortal(sv));
4982                 }
4983             }
4984             break;
4985         case 'u':
4986             /* MKS:
4987              * Initialise the decode mapping.  By using a table driven
4988              * algorithm, the code will be character-set independent
4989              * (and just as fast as doing character arithmetic)
4990              */
4991             if (PL_uudmap['M'] == 0) {
4992                 int i;
4993
4994                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4995                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4996                 /*
4997                  * Because ' ' and '`' map to the same value,
4998                  * we need to decode them both the same.
4999                  */
5000                 PL_uudmap[' '] = 0;
5001             }
5002
5003             along = (strend - s) * 3 / 4;
5004             sv = NEWSV(42, along);
5005             if (along)
5006                 SvPOK_on(sv);
5007             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5008                 I32 a, b, c, d;
5009                 char hunk[4];
5010
5011                 hunk[3] = '\0';
5012                 len = PL_uudmap[*(U8*)s++] & 077;
5013                 while (len > 0) {
5014                     if (s < strend && ISUUCHAR(*s))
5015                         a = PL_uudmap[*(U8*)s++] & 077;
5016                     else
5017                         a = 0;
5018                     if (s < strend && ISUUCHAR(*s))
5019                         b = PL_uudmap[*(U8*)s++] & 077;
5020                     else
5021                         b = 0;
5022                     if (s < strend && ISUUCHAR(*s))
5023                         c = PL_uudmap[*(U8*)s++] & 077;
5024                     else
5025                         c = 0;
5026                     if (s < strend && ISUUCHAR(*s))
5027                         d = PL_uudmap[*(U8*)s++] & 077;
5028                     else
5029                         d = 0;
5030                     hunk[0] = (a << 2) | (b >> 4);
5031                     hunk[1] = (b << 4) | (c >> 2);
5032                     hunk[2] = (c << 6) | d;
5033                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5034                     len -= 3;
5035                 }
5036                 if (*s == '\n')
5037                     s++;
5038                 else if (s[1] == '\n')          /* possible checksum byte */
5039                     s += 2;
5040             }
5041             XPUSHs(sv_2mortal(sv));
5042             break;
5043         }
5044         if (checksum) {
5045             sv = NEWSV(42, 0);
5046             if (strchr("fFdD", datumtype) ||
5047               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5048                 NV trouble;
5049
5050                 adouble = 1.0;
5051                 while (checksum >= 16) {
5052                     checksum -= 16;
5053                     adouble *= 65536.0;
5054                 }
5055                 while (checksum >= 4) {
5056                     checksum -= 4;
5057                     adouble *= 16.0;
5058                 }
5059                 while (checksum--)
5060                     adouble *= 2.0;
5061                 along = (1 << checksum) - 1;
5062                 while (cdouble < 0.0)
5063                     cdouble += adouble;
5064                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5065                 sv_setnv(sv, cdouble);
5066             }
5067             else {
5068                 if (checksum < 32) {
5069                     aulong = (1 << checksum) - 1;
5070                     culong &= aulong;
5071                 }
5072                 sv_setuv(sv, (UV)culong);
5073             }
5074             XPUSHs(sv_2mortal(sv));
5075             checksum = 0;
5076         }
5077     }
5078     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5079         PUSHs(&PL_sv_undef);
5080     RETURN;
5081 }
5082
5083 STATIC void
5084 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5085 {
5086     char hunk[5];
5087
5088     *hunk = PL_uuemap[len];
5089     sv_catpvn(sv, hunk, 1);
5090     hunk[4] = '\0';
5091     while (len > 2) {
5092         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5093         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5094         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5095         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5096         sv_catpvn(sv, hunk, 4);
5097         s += 3;
5098         len -= 3;
5099     }
5100     if (len > 0) {
5101         char r = (len > 1 ? s[1] : '\0');
5102         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5103         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5104         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5105         hunk[3] = PL_uuemap[0];
5106         sv_catpvn(sv, hunk, 4);
5107     }
5108     sv_catpvn(sv, "\n", 1);
5109 }
5110
5111 STATIC SV *
5112 S_is_an_int(pTHX_ char *s, STRLEN l)
5113 {
5114   STRLEN         n_a;
5115   SV             *result = newSVpvn(s, l);
5116   char           *result_c = SvPV(result, n_a); /* convenience */
5117   char           *out = result_c;
5118   bool            skip = 1;
5119   bool            ignore = 0;
5120
5121   while (*s) {
5122     switch (*s) {
5123     case ' ':
5124       break;
5125     case '+':
5126       if (!skip) {
5127         SvREFCNT_dec(result);
5128         return (NULL);
5129       }
5130       break;
5131     case '0':
5132     case '1':
5133     case '2':
5134     case '3':
5135     case '4':
5136     case '5':
5137     case '6':
5138     case '7':
5139     case '8':
5140     case '9':
5141       skip = 0;
5142       if (!ignore) {
5143         *(out++) = *s;
5144       }
5145       break;
5146     case '.':
5147       ignore = 1;
5148       break;
5149     default:
5150       SvREFCNT_dec(result);
5151       return (NULL);
5152     }
5153     s++;
5154   }
5155   *(out++) = '\0';
5156   SvCUR_set(result, out - result_c);
5157   return (result);
5158 }
5159
5160 /* pnum must be '\0' terminated */
5161 STATIC int
5162 S_div128(pTHX_ SV *pnum, bool *done)
5163 {
5164   STRLEN          len;
5165   char           *s = SvPV(pnum, len);
5166   int             m = 0;
5167   int             r = 0;
5168   char           *t = s;
5169
5170   *done = 1;
5171   while (*t) {
5172     int             i;
5173
5174     i = m * 10 + (*t - '0');
5175     m = i & 0x7F;
5176     r = (i >> 7);               /* r < 10 */
5177     if (r) {
5178       *done = 0;
5179     }
5180     *(t++) = '0' + r;
5181   }
5182   *(t++) = '\0';
5183   SvCUR_set(pnum, (STRLEN) (t - s));
5184   return (m);
5185 }
5186
5187
5188 PP(pp_pack)
5189 {
5190     dSP; dMARK; dORIGMARK; dTARGET;
5191     register SV *cat = TARG;
5192     register I32 items;
5193     STRLEN fromlen;
5194     register char *pat = SvPVx(*++MARK, fromlen);
5195     char *patcopy;
5196     register char *patend = pat + fromlen;
5197     register I32 len;
5198     I32 datumtype;
5199     SV *fromstr;
5200     /*SUPPRESS 442*/
5201     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5202     static char *space10 = "          ";
5203
5204     /* These must not be in registers: */
5205     char achar;
5206     I16 ashort;
5207     int aint;
5208     unsigned int auint;
5209     I32 along;
5210     U32 aulong;
5211 #ifdef HAS_QUAD
5212     Quad_t aquad;
5213     Uquad_t auquad;
5214 #endif
5215     char *aptr;
5216     float afloat;
5217     double adouble;
5218     int commas = 0;
5219 #ifdef PERL_NATINT_PACK
5220     int natint;         /* native integer */
5221 #endif
5222
5223     items = SP - MARK;
5224     MARK++;
5225     sv_setpvn(cat, "", 0);
5226     patcopy = pat;
5227     while (pat < patend) {
5228         SV *lengthcode = Nullsv;
5229 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5230         datumtype = *pat++ & 0xFF;
5231 #ifdef PERL_NATINT_PACK
5232         natint = 0;
5233 #endif
5234         if (isSPACE(datumtype)) {
5235             patcopy++;
5236             continue;
5237         }
5238 #ifndef PACKED_IS_OCTETS
5239         if (datumtype == 'U' && pat == patcopy+1)
5240             SvUTF8_on(cat);
5241 #endif
5242         if (datumtype == '#') {
5243             while (pat < patend && *pat != '\n')
5244                 pat++;
5245             continue;
5246         }
5247         if (*pat == '!') {
5248             char *natstr = "sSiIlL";
5249
5250             if (strchr(natstr, datumtype)) {
5251 #ifdef PERL_NATINT_PACK
5252                 natint = 1;
5253 #endif
5254                 pat++;
5255             }
5256             else
5257                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5258         }
5259         if (*pat == '*') {
5260             len = strchr("@Xxu", datumtype) ? 0 : items;
5261             pat++;
5262         }
5263         else if (isDIGIT(*pat)) {
5264             len = *pat++ - '0';
5265             while (isDIGIT(*pat)) {
5266                 len = (len * 10) + (*pat++ - '0');
5267                 if (len < 0)
5268                     DIE(aTHX_ "Repeat count in pack overflows");
5269             }
5270         }
5271         else
5272             len = 1;
5273         if (*pat == '/') {
5274             ++pat;
5275             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5276                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5277             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5278                                                    ? *MARK : &PL_sv_no)
5279                                             + (*pat == 'Z' ? 1 : 0)));
5280         }
5281         switch(datumtype) {
5282         default:
5283             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5284         case ',': /* grandfather in commas but with a warning */
5285             if (commas++ == 0 && ckWARN(WARN_PACK))
5286                 Perl_warner(aTHX_ WARN_PACK,
5287                             "Invalid type in pack: '%c'", (int)datumtype);
5288             break;
5289         case '%':
5290             DIE(aTHX_ "%% may only be used in unpack");
5291         case '@':
5292             len -= SvCUR(cat);
5293             if (len > 0)
5294                 goto grow;
5295             len = -len;
5296             if (len > 0)
5297                 goto shrink;
5298             break;
5299         case 'X':
5300           shrink:
5301             if (SvCUR(cat) < len)
5302                 DIE(aTHX_ "X outside of string");
5303             SvCUR(cat) -= len;
5304             *SvEND(cat) = '\0';
5305             break;
5306         case 'x':
5307           grow:
5308             while (len >= 10) {
5309                 sv_catpvn(cat, null10, 10);
5310                 len -= 10;
5311             }
5312             sv_catpvn(cat, null10, len);
5313             break;
5314         case 'A':
5315         case 'Z':
5316         case 'a':
5317             fromstr = NEXTFROM;
5318             aptr = SvPV(fromstr, fromlen);
5319             if (pat[-1] == '*') {
5320                 len = fromlen;
5321                 if (datumtype == 'Z')
5322                     ++len;
5323             }
5324             if (fromlen >= len) {
5325                 sv_catpvn(cat, aptr, len);
5326                 if (datumtype == 'Z')
5327                     *(SvEND(cat)-1) = '\0';
5328             }
5329             else {
5330                 sv_catpvn(cat, aptr, fromlen);
5331                 len -= fromlen;
5332                 if (datumtype == 'A') {
5333                     while (len >= 10) {
5334                         sv_catpvn(cat, space10, 10);
5335                         len -= 10;
5336                     }
5337                     sv_catpvn(cat, space10, len);
5338                 }
5339                 else {
5340                     while (len >= 10) {
5341                         sv_catpvn(cat, null10, 10);
5342                         len -= 10;
5343                     }
5344                     sv_catpvn(cat, null10, len);
5345                 }
5346             }
5347             break;
5348         case 'B':
5349         case 'b':
5350             {
5351                 register char *str;
5352                 I32 saveitems;
5353
5354                 fromstr = NEXTFROM;
5355                 saveitems = items;
5356                 str = SvPV(fromstr, fromlen);
5357                 if (pat[-1] == '*')
5358                     len = fromlen;
5359                 aint = SvCUR(cat);
5360                 SvCUR(cat) += (len+7)/8;
5361                 SvGROW(cat, SvCUR(cat) + 1);
5362                 aptr = SvPVX(cat) + aint;
5363                 if (len > fromlen)
5364                     len = fromlen;
5365                 aint = len;
5366                 items = 0;
5367                 if (datumtype == 'B') {
5368                     for (len = 0; len++ < aint;) {
5369                         items |= *str++ & 1;
5370                         if (len & 7)
5371                             items <<= 1;
5372                         else {
5373                             *aptr++ = items & 0xff;
5374                             items = 0;
5375                         }
5376                     }
5377                 }
5378                 else {
5379                     for (len = 0; len++ < aint;) {
5380                         if (*str++ & 1)
5381                             items |= 128;
5382                         if (len & 7)
5383                             items >>= 1;
5384                         else {
5385                             *aptr++ = items & 0xff;
5386                             items = 0;
5387                         }
5388                     }
5389                 }
5390                 if (aint & 7) {
5391                     if (datumtype == 'B')
5392                         items <<= 7 - (aint & 7);
5393                     else
5394                         items >>= 7 - (aint & 7);
5395                     *aptr++ = items & 0xff;
5396                 }
5397                 str = SvPVX(cat) + SvCUR(cat);
5398                 while (aptr <= str)
5399                     *aptr++ = '\0';
5400
5401                 items = saveitems;
5402             }
5403             break;
5404         case 'H':
5405         case 'h':
5406             {
5407                 register char *str;
5408                 I32 saveitems;
5409
5410                 fromstr = NEXTFROM;
5411                 saveitems = items;
5412                 str = SvPV(fromstr, fromlen);
5413                 if (pat[-1] == '*')
5414                     len = fromlen;
5415                 aint = SvCUR(cat);
5416                 SvCUR(cat) += (len+1)/2;
5417                 SvGROW(cat, SvCUR(cat) + 1);
5418                 aptr = SvPVX(cat) + aint;
5419                 if (len > fromlen)
5420                     len = fromlen;
5421                 aint = len;
5422                 items = 0;
5423                 if (datumtype == 'H') {
5424                     for (len = 0; len++ < aint;) {
5425                         if (isALPHA(*str))
5426                             items |= ((*str++ & 15) + 9) & 15;
5427                         else
5428                             items |= *str++ & 15;
5429                         if (len & 1)
5430                             items <<= 4;
5431                         else {
5432                             *aptr++ = items & 0xff;
5433                             items = 0;
5434                         }
5435                     }
5436                 }
5437                 else {
5438                     for (len = 0; len++ < aint;) {
5439                         if (isALPHA(*str))
5440                             items |= (((*str++ & 15) + 9) & 15) << 4;
5441                         else
5442                             items |= (*str++ & 15) << 4;
5443                         if (len & 1)
5444                             items >>= 4;
5445                         else {
5446                             *aptr++ = items & 0xff;
5447                             items = 0;
5448                         }
5449                     }
5450                 }
5451                 if (aint & 1)
5452                     *aptr++ = items & 0xff;
5453                 str = SvPVX(cat) + SvCUR(cat);
5454                 while (aptr <= str)
5455                     *aptr++ = '\0';
5456
5457                 items = saveitems;
5458             }
5459             break;
5460         case 'C':
5461         case 'c':
5462             while (len-- > 0) {
5463                 fromstr = NEXTFROM;
5464                 aint = SvIV(fromstr);
5465                 achar = aint;
5466                 sv_catpvn(cat, &achar, sizeof(char));
5467             }
5468             break;
5469         case 'U':
5470             while (len-- > 0) {
5471                 fromstr = NEXTFROM;
5472                 auint = SvUV(fromstr);
5473                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5474                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5475                                - SvPVX(cat));
5476             }
5477             *SvEND(cat) = '\0';
5478             break;
5479         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5480         case 'f':
5481         case 'F':
5482             while (len-- > 0) {
5483                 fromstr = NEXTFROM;
5484                 afloat = (float)SvNV(fromstr);
5485                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5486             }
5487             break;
5488         case 'd':
5489         case 'D':
5490             while (len-- > 0) {
5491                 fromstr = NEXTFROM;
5492                 adouble = (double)SvNV(fromstr);
5493                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5494             }
5495             break;
5496         case 'n':
5497             while (len-- > 0) {
5498                 fromstr = NEXTFROM;
5499                 ashort = (I16)SvIV(fromstr);
5500 #ifdef HAS_HTONS
5501                 ashort = PerlSock_htons(ashort);
5502 #endif
5503                 CAT16(cat, &ashort);
5504             }
5505             break;
5506         case 'v':
5507             while (len-- > 0) {
5508                 fromstr = NEXTFROM;
5509                 ashort = (I16)SvIV(fromstr);
5510 #ifdef HAS_HTOVS
5511                 ashort = htovs(ashort);
5512 #endif
5513                 CAT16(cat, &ashort);
5514             }
5515             break;
5516         case 'S':
5517 #if SHORTSIZE != SIZE16
5518             if (natint) {
5519                 unsigned short aushort;
5520
5521                 while (len-- > 0) {
5522                     fromstr = NEXTFROM;
5523                     aushort = SvUV(fromstr);
5524                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5525                 }
5526             }
5527             else
5528 #endif
5529             {
5530                 U16 aushort;
5531
5532                 while (len-- > 0) {
5533                     fromstr = NEXTFROM;
5534                     aushort = (U16)SvUV(fromstr);
5535                     CAT16(cat, &aushort);
5536                 }
5537
5538             }
5539             break;
5540         case 's':
5541 #if SHORTSIZE != SIZE16
5542             if (natint) {
5543                 short ashort;
5544
5545                 while (len-- > 0) {
5546                     fromstr = NEXTFROM;
5547                     ashort = SvIV(fromstr);
5548                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5549                 }
5550             }
5551             else
5552 #endif
5553             {
5554                 while (len-- > 0) {
5555                     fromstr = NEXTFROM;
5556                     ashort = (I16)SvIV(fromstr);
5557                     CAT16(cat, &ashort);
5558                 }
5559             }
5560             break;
5561         case 'I':
5562             while (len-- > 0) {
5563                 fromstr = NEXTFROM;
5564                 auint = SvUV(fromstr);
5565                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5566             }
5567             break;
5568         case 'w':
5569             while (len-- > 0) {
5570                 fromstr = NEXTFROM;
5571                 adouble = Perl_floor(SvNV(fromstr));
5572
5573                 if (adouble < 0)
5574                     DIE(aTHX_ "Cannot compress negative numbers");
5575
5576                 if (
5577 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5578                     adouble <= 0xffffffff
5579 #else
5580 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5581                     adouble <= UV_MAX_cxux
5582 #   else
5583                     adouble <= UV_MAX
5584 #   endif
5585 #endif
5586                     )
5587                 {
5588                     char   buf[1 + sizeof(UV)];
5589                     char  *in = buf + sizeof(buf);
5590                     UV     auv = U_V(adouble);
5591
5592                     do {
5593                         *--in = (auv & 0x7f) | 0x80;
5594                         auv >>= 7;
5595                     } while (auv);
5596                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5597                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5598                 }
5599                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5600                     char           *from, *result, *in;
5601                     SV             *norm;
5602                     STRLEN          len;
5603                     bool            done;
5604
5605                     /* Copy string and check for compliance */
5606                     from = SvPV(fromstr, len);
5607                     if ((norm = is_an_int(from, len)) == NULL)
5608                         DIE(aTHX_ "can compress only unsigned integer");
5609
5610                     New('w', result, len, char);
5611                     in = result + len;
5612                     done = FALSE;
5613                     while (!done)
5614                         *--in = div128(norm, &done) | 0x80;
5615                     result[len - 1] &= 0x7F; /* clear continue bit */
5616                     sv_catpvn(cat, in, (result + len) - in);
5617                     Safefree(result);
5618                     SvREFCNT_dec(norm); /* free norm */
5619                 }
5620                 else if (SvNOKp(fromstr)) {
5621                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5622                     char  *in = buf + sizeof(buf);
5623
5624                     do {
5625                         double next = floor(adouble / 128);
5626                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5627                         if (in <= buf)  /* this cannot happen ;-) */
5628                             DIE(aTHX_ "Cannot compress integer");
5629                         in--;
5630                         adouble = next;
5631                     } while (adouble > 0);
5632                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5633                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5634                 }
5635                 else
5636                     DIE(aTHX_ "Cannot compress non integer");
5637             }
5638             break;
5639         case 'i':
5640             while (len-- > 0) {
5641                 fromstr = NEXTFROM;
5642                 aint = SvIV(fromstr);
5643                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5644             }
5645             break;
5646         case 'N':
5647             while (len-- > 0) {
5648                 fromstr = NEXTFROM;
5649                 aulong = SvUV(fromstr);
5650 #ifdef HAS_HTONL
5651                 aulong = PerlSock_htonl(aulong);
5652 #endif
5653                 CAT32(cat, &aulong);
5654             }
5655             break;
5656         case 'V':
5657             while (len-- > 0) {
5658                 fromstr = NEXTFROM;
5659                 aulong = SvUV(fromstr);
5660 #ifdef HAS_HTOVL
5661                 aulong = htovl(aulong);
5662 #endif
5663                 CAT32(cat, &aulong);
5664             }
5665             break;
5666         case 'L':
5667 #if LONGSIZE != SIZE32
5668             if (natint) {
5669                 unsigned long aulong;
5670
5671                 while (len-- > 0) {
5672                     fromstr = NEXTFROM;
5673                     aulong = SvUV(fromstr);
5674                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5675                 }
5676             }
5677             else
5678 #endif
5679             {
5680                 while (len-- > 0) {
5681                     fromstr = NEXTFROM;
5682                     aulong = SvUV(fromstr);
5683                     CAT32(cat, &aulong);
5684                 }
5685             }
5686             break;
5687         case 'l':
5688 #if LONGSIZE != SIZE32
5689             if (natint) {
5690                 long along;
5691
5692                 while (len-- > 0) {
5693                     fromstr = NEXTFROM;
5694                     along = SvIV(fromstr);
5695                     sv_catpvn(cat, (char *)&along, sizeof(long));
5696                 }
5697             }
5698             else
5699 #endif
5700             {
5701                 while (len-- > 0) {
5702                     fromstr = NEXTFROM;
5703                     along = SvIV(fromstr);
5704                     CAT32(cat, &along);
5705                 }
5706             }
5707             break;
5708 #ifdef HAS_QUAD
5709         case 'Q':
5710             while (len-- > 0) {
5711                 fromstr = NEXTFROM;
5712                 auquad = (Uquad_t)SvUV(fromstr);
5713                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5714             }
5715             break;
5716         case 'q':
5717             while (len-- > 0) {
5718                 fromstr = NEXTFROM;
5719                 aquad = (Quad_t)SvIV(fromstr);
5720                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5721             }
5722             break;
5723 #endif
5724         case 'P':
5725             len = 1;            /* assume SV is correct length */
5726             /* FALL THROUGH */
5727         case 'p':
5728             while (len-- > 0) {
5729                 fromstr = NEXTFROM;
5730                 if (fromstr == &PL_sv_undef)
5731                     aptr = NULL;
5732                 else {
5733                     STRLEN n_a;
5734                     /* XXX better yet, could spirit away the string to
5735                      * a safe spot and hang on to it until the result
5736                      * of pack() (and all copies of the result) are
5737                      * gone.
5738                      */
5739                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5740                                                 || (SvPADTMP(fromstr)
5741                                                     && !SvREADONLY(fromstr))))
5742                     {
5743                         Perl_warner(aTHX_ WARN_PACK,
5744                                 "Attempt to pack pointer to temporary value");
5745                     }
5746                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5747                         aptr = SvPV(fromstr,n_a);
5748                     else
5749                         aptr = SvPV_force(fromstr,n_a);
5750                 }
5751                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5752             }
5753             break;
5754         case 'u':
5755             fromstr = NEXTFROM;
5756             aptr = SvPV(fromstr, fromlen);
5757             SvGROW(cat, fromlen * 4 / 3);
5758             if (len <= 1)
5759                 len = 45;
5760             else
5761                 len = len / 3 * 3;
5762             while (fromlen > 0) {
5763                 I32 todo;
5764
5765                 if (fromlen > len)
5766                     todo = len;
5767                 else
5768                     todo = fromlen;
5769                 doencodes(cat, aptr, todo);
5770                 fromlen -= todo;
5771                 aptr += todo;
5772             }
5773             break;
5774         }
5775     }
5776     SvSETMAGIC(cat);
5777     SP = ORIGMARK;
5778     PUSHs(cat);
5779     RETURN;
5780 }
5781 #undef NEXTFROM
5782
5783
5784 PP(pp_split)
5785 {
5786     dSP; dTARG;
5787     AV *ary;
5788     register IV limit = POPi;                   /* note, negative is forever */
5789     SV *sv = POPs;
5790     STRLEN len;
5791     register char *s = SvPV(sv, len);
5792     bool do_utf8 = DO_UTF8(sv);
5793     char *strend = s + len;
5794     register PMOP *pm;
5795     register REGEXP *rx;
5796     register SV *dstr;
5797     register char *m;
5798     I32 iters = 0;
5799     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5800     I32 maxiters = slen + 10;
5801     I32 i;
5802     char *orig;
5803     I32 origlimit = limit;
5804     I32 realarray = 0;
5805     I32 base;
5806     AV *oldstack = PL_curstack;
5807     I32 gimme = GIMME_V;
5808     I32 oldsave = PL_savestack_ix;
5809     I32 make_mortal = 1;
5810     MAGIC *mg = (MAGIC *) NULL;
5811
5812 #ifdef DEBUGGING
5813     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5814 #else
5815     pm = (PMOP*)POPs;
5816 #endif
5817     if (!pm || !s)
5818         DIE(aTHX_ "panic: pp_split");
5819     rx = pm->op_pmregexp;
5820
5821     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5822              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5823
5824     if (pm->op_pmreplroot) {
5825 #ifdef USE_ITHREADS
5826         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5827 #else
5828         ary = GvAVn((GV*)pm->op_pmreplroot);
5829 #endif
5830     }
5831     else if (gimme != G_ARRAY)
5832 #ifdef USE_THREADS
5833         ary = (AV*)PL_curpad[0];
5834 #else
5835         ary = GvAVn(PL_defgv);
5836 #endif /* USE_THREADS */
5837     else
5838         ary = Nullav;
5839     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5840         realarray = 1;
5841         PUTBACK;
5842         av_extend(ary,0);
5843         av_clear(ary);
5844         SPAGAIN;
5845         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5846             PUSHMARK(SP);
5847             XPUSHs(SvTIED_obj((SV*)ary, mg));
5848         }
5849         else {
5850             if (!AvREAL(ary)) {
5851                 AvREAL_on(ary);
5852                 AvREIFY_off(ary);
5853                 for (i = AvFILLp(ary); i >= 0; i--)
5854                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5855             }
5856             /* temporarily switch stacks */
5857             SWITCHSTACK(PL_curstack, ary);
5858             make_mortal = 0;
5859         }
5860     }
5861     base = SP - PL_stack_base;
5862     orig = s;
5863     if (pm->op_pmflags & PMf_SKIPWHITE) {
5864         if (pm->op_pmflags & PMf_LOCALE) {
5865             while (isSPACE_LC(*s))
5866                 s++;
5867         }
5868         else {
5869             while (isSPACE(*s))
5870                 s++;
5871         }
5872     }
5873     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5874         SAVEINT(PL_multiline);
5875         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5876     }
5877
5878     if (!limit)
5879         limit = maxiters + 2;
5880     if (pm->op_pmflags & PMf_WHITE) {
5881         while (--limit) {
5882             m = s;
5883             while (m < strend &&
5884                    !((pm->op_pmflags & PMf_LOCALE)
5885                      ? isSPACE_LC(*m) : isSPACE(*m)))
5886                 ++m;
5887             if (m >= strend)
5888                 break;
5889
5890             dstr = NEWSV(30, m-s);
5891             sv_setpvn(dstr, s, m-s);
5892             if (make_mortal)
5893                 sv_2mortal(dstr);
5894             if (do_utf8)
5895                 (void)SvUTF8_on(dstr);
5896             XPUSHs(dstr);
5897
5898             s = m + 1;
5899             while (s < strend &&
5900                    ((pm->op_pmflags & PMf_LOCALE)
5901                     ? isSPACE_LC(*s) : isSPACE(*s)))
5902                 ++s;
5903         }
5904     }
5905     else if (strEQ("^", rx->precomp)) {
5906         while (--limit) {
5907             /*SUPPRESS 530*/
5908             for (m = s; m < strend && *m != '\n'; m++) ;
5909             m++;
5910             if (m >= strend)
5911                 break;
5912             dstr = NEWSV(30, m-s);
5913             sv_setpvn(dstr, s, m-s);
5914             if (make_mortal)
5915                 sv_2mortal(dstr);
5916             if (do_utf8)
5917                 (void)SvUTF8_on(dstr);
5918             XPUSHs(dstr);
5919             s = m;
5920         }
5921     }
5922     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5923              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5924              && (rx->reganch & ROPT_CHECK_ALL)
5925              && !(rx->reganch & ROPT_ANCH)) {
5926         int tail = (rx->reganch & RE_INTUIT_TAIL);
5927         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5928
5929         len = rx->minlen;
5930         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5931             STRLEN n_a;
5932             char c = *SvPV(csv, n_a);
5933             while (--limit) {
5934                 /*SUPPRESS 530*/
5935                 for (m = s; m < strend && *m != c; m++) ;
5936                 if (m >= strend)
5937                     break;
5938                 dstr = NEWSV(30, m-s);
5939                 sv_setpvn(dstr, s, m-s);
5940                 if (make_mortal)
5941                     sv_2mortal(dstr);
5942                 if (do_utf8)
5943                     (void)SvUTF8_on(dstr);
5944                 XPUSHs(dstr);
5945                 /* The rx->minlen is in characters but we want to step
5946                  * s ahead by bytes. */
5947                 if (do_utf8)
5948                     s = (char*)utf8_hop((U8*)m, len);
5949                 else
5950                     s = m + len; /* Fake \n at the end */
5951             }
5952         }
5953         else {
5954 #ifndef lint
5955             while (s < strend && --limit &&
5956               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5957                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5958 #endif
5959             {
5960                 dstr = NEWSV(31, m-s);
5961                 sv_setpvn(dstr, s, m-s);
5962                 if (make_mortal)
5963                     sv_2mortal(dstr);
5964                 if (do_utf8)
5965                     (void)SvUTF8_on(dstr);
5966                 XPUSHs(dstr);
5967                 /* The rx->minlen is in characters but we want to step
5968                  * s ahead by bytes. */
5969                 if (do_utf8)
5970                     s = (char*)utf8_hop((U8*)m, len);
5971                 else
5972                     s = m + len; /* Fake \n at the end */
5973             }
5974         }
5975     }
5976     else {
5977         maxiters += slen * rx->nparens;
5978         while (s < strend && --limit
5979 /*             && (!rx->check_substr
5980                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5981                                                  0, NULL))))
5982 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5983                               1 /* minend */, sv, NULL, 0))
5984         {
5985             TAINT_IF(RX_MATCH_TAINTED(rx));
5986             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5987                 m = s;
5988                 s = orig;
5989                 orig = rx->subbeg;
5990                 s = orig + (m - s);
5991                 strend = s + (strend - m);
5992             }
5993             m = rx->startp[0] + orig;
5994             dstr = NEWSV(32, m-s);
5995             sv_setpvn(dstr, s, m-s);
5996             if (make_mortal)
5997                 sv_2mortal(dstr);
5998             if (do_utf8)
5999                 (void)SvUTF8_on(dstr);
6000             XPUSHs(dstr);
6001             if (rx->nparens) {
6002                 for (i = 1; i <= rx->nparens; i++) {
6003                     s = rx->startp[i] + orig;
6004                     m = rx->endp[i] + orig;
6005                     if (m && s) {
6006                         dstr = NEWSV(33, m-s);
6007                         sv_setpvn(dstr, s, m-s);
6008                     }
6009                     else
6010                         dstr = NEWSV(33, 0);
6011                     if (make_mortal)
6012                         sv_2mortal(dstr);
6013                     if (do_utf8)
6014                         (void)SvUTF8_on(dstr);
6015                     XPUSHs(dstr);
6016                 }
6017             }
6018             s = rx->endp[0] + orig;
6019         }
6020     }
6021
6022     LEAVE_SCOPE(oldsave);
6023     iters = (SP - PL_stack_base) - base;
6024     if (iters > maxiters)
6025         DIE(aTHX_ "Split loop");
6026
6027     /* keep field after final delim? */
6028     if (s < strend || (iters && origlimit)) {
6029         STRLEN l = strend - s;
6030         dstr = NEWSV(34, l);
6031         sv_setpvn(dstr, s, l);
6032         if (make_mortal)
6033             sv_2mortal(dstr);
6034         if (do_utf8)
6035             (void)SvUTF8_on(dstr);
6036         XPUSHs(dstr);
6037         iters++;
6038     }
6039     else if (!origlimit) {
6040         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6041             iters--, SP--;
6042     }
6043
6044     if (realarray) {
6045         if (!mg) {
6046             SWITCHSTACK(ary, oldstack);
6047             if (SvSMAGICAL(ary)) {
6048                 PUTBACK;
6049                 mg_set((SV*)ary);
6050                 SPAGAIN;
6051             }
6052             if (gimme == G_ARRAY) {
6053                 EXTEND(SP, iters);
6054                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6055                 SP += iters;
6056                 RETURN;
6057             }
6058         }
6059         else {
6060             PUTBACK;
6061             ENTER;
6062             call_method("PUSH",G_SCALAR|G_DISCARD);
6063             LEAVE;
6064             SPAGAIN;
6065             if (gimme == G_ARRAY) {
6066                 /* EXTEND should not be needed - we just popped them */
6067                 EXTEND(SP, iters);
6068                 for (i=0; i < iters; i++) {
6069                     SV **svp = av_fetch(ary, i, FALSE);
6070                     PUSHs((svp) ? *svp : &PL_sv_undef);
6071                 }
6072                 RETURN;
6073             }
6074         }
6075     }
6076     else {
6077         if (gimme == G_ARRAY)
6078             RETURN;
6079     }
6080     if (iters || !pm->op_pmreplroot) {
6081         GETTARGET;
6082         PUSHi(iters);
6083         RETURN;
6084     }
6085     RETPUSHUNDEF;
6086 }
6087
6088 #ifdef USE_THREADS
6089 void
6090 Perl_unlock_condpair(pTHX_ void *svv)
6091 {
6092     MAGIC *mg = mg_find((SV*)svv, 'm');
6093
6094     if (!mg)
6095         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6096     MUTEX_LOCK(MgMUTEXP(mg));
6097     if (MgOWNER(mg) != thr)
6098         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6099     MgOWNER(mg) = 0;
6100     COND_SIGNAL(MgOWNERCONDP(mg));
6101     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6102                           PTR2UV(thr), PTR2UV(svv));)
6103     MUTEX_UNLOCK(MgMUTEXP(mg));
6104 }
6105 #endif /* USE_THREADS */
6106
6107 PP(pp_lock)
6108 {
6109     dSP;
6110     dTOPss;
6111     SV *retsv = sv;
6112 #ifdef USE_THREADS
6113     sv_lock(sv);
6114 #endif /* USE_THREADS */
6115     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6116         || SvTYPE(retsv) == SVt_PVCV) {
6117         retsv = refto(retsv);
6118     }
6119     SETs(retsv);
6120     RETURN;
6121 }
6122
6123 PP(pp_threadsv)
6124 {
6125 #ifdef USE_THREADS
6126     dSP;
6127     EXTEND(SP, 1);
6128     if (PL_op->op_private & OPpLVAL_INTRO)
6129         PUSHs(*save_threadsv(PL_op->op_targ));
6130     else
6131         PUSHs(THREADSV(PL_op->op_targ));
6132     RETURN;
6133 #else
6134     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6135 #endif /* USE_THREADS */
6136 }