pp.c

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