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