pp.c

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