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