pp.c

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