pp.c

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