pp.c

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