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