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