pp.c

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