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