pp.c

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