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