pp.c

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