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