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