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;
1097         UV right;
1098         bool left_neg;
1099         bool right_neg;
1100         bool use_double = 0;
1101         NV dright;
1102         NV dleft;
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;
1269         bool auvok;
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 = ((PL_op->op_private & OPpLOCALE)
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 = ((PL_op->op_private & OPpLOCALE)
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 = ((PL_op->op_private & OPpLOCALE)
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 = ((PL_op->op_private & OPpLOCALE)
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 = ((PL_op->op_private & OPpLOCALE)
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                   (void)Perl_modf(value, &value);
2602 #else
2603                   double tmp = (double)value;
2604                   (void)Perl_modf(tmp, &tmp);
2605                   value = (NV)tmp;
2606 #endif
2607                   SETn(value);
2608               }
2609           }
2610           else {
2611               if (value > (NV)IV_MIN - 0.5) {
2612                   SETi(I_V(value));
2613               } else {
2614 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2615                   (void)Perl_modf(-value, &value);
2616                   value = -value;
2617 #else
2618                   double tmp = (double)value;
2619                   (void)Perl_modf(-tmp, &tmp);
2620                   value = -(NV)tmp;
2621 #endif
2622                   SETn(value);
2623               }
2624           }
2625       }
2626     }
2627     RETURN;
2628 }
2629
2630 PP(pp_abs)
2631 {
2632     dSP; dTARGET; tryAMAGICun(abs);
2633     {
2634       /* This will cache the NV value if string isn't actually integer  */
2635       IV iv = TOPi;
2636
2637       if (SvIOK(TOPs)) {
2638         /* IVX is precise  */
2639         if (SvIsUV(TOPs)) {
2640           SETu(TOPu);   /* force it to be numeric only */
2641         } else {
2642           if (iv >= 0) {
2643             SETi(iv);
2644           } else {
2645             if (iv != IV_MIN) {
2646               SETi(-iv);
2647             } else {
2648               /* 2s complement assumption. Also, not really needed as
2649                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2650               SETu(IV_MIN);
2651             }
2652           }
2653         }
2654       } else{
2655         NV value = TOPn;
2656         if (value < 0.0)
2657           value = -value;
2658         SETn(value);
2659       }
2660     }
2661     RETURN;
2662 }
2663
2664 PP(pp_hex)
2665 {
2666     dSP; dTARGET;
2667     char *tmps;
2668     STRLEN argtype;
2669     STRLEN len;
2670
2671     tmps = (SvPVx(POPs, len));
2672     argtype = 1;                /* allow underscores */
2673     XPUSHn(scan_hex(tmps, len, &argtype));
2674     RETURN;
2675 }
2676
2677 PP(pp_oct)
2678 {
2679     dSP; dTARGET;
2680     NV value;
2681     STRLEN argtype;
2682     char *tmps;
2683     STRLEN len;
2684
2685     tmps = (SvPVx(POPs, len));
2686     while (*tmps && len && isSPACE(*tmps))
2687        tmps++, len--;
2688     if (*tmps == '0')
2689        tmps++, len--;
2690     argtype = 1;                /* allow underscores */
2691     if (*tmps == 'x')
2692        value = scan_hex(++tmps, --len, &argtype);
2693     else if (*tmps == 'b')
2694        value = scan_bin(++tmps, --len, &argtype);
2695     else
2696        value = scan_oct(tmps, len, &argtype);
2697     XPUSHn(value);
2698     RETURN;
2699 }
2700
2701 /* String stuff. */
2702
2703 PP(pp_length)
2704 {
2705     dSP; dTARGET;
2706     SV *sv = TOPs;
2707
2708     if (DO_UTF8(sv))
2709         SETi(sv_len_utf8(sv));
2710     else
2711         SETi(sv_len(sv));
2712     RETURN;
2713 }
2714
2715 PP(pp_substr)
2716 {
2717     dSP; dTARGET;
2718     SV *sv;
2719     I32 len;
2720     STRLEN curlen;
2721     STRLEN utf8_curlen;
2722     I32 pos;
2723     I32 rem;
2724     I32 fail;
2725     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2726     char *tmps;
2727     I32 arybase = PL_curcop->cop_arybase;
2728     SV *repl_sv = NULL;
2729     char *repl = 0;
2730     STRLEN repl_len;
2731     int num_args = PL_op->op_private & 7;
2732     bool repl_need_utf8_upgrade = FALSE;
2733     bool repl_is_utf8 = FALSE;
2734
2735     SvTAINTED_off(TARG);                        /* decontaminate */
2736     SvUTF8_off(TARG);                           /* decontaminate */
2737     if (num_args > 2) {
2738         if (num_args > 3) {
2739             repl_sv = POPs;
2740             repl = SvPV(repl_sv, repl_len);
2741             repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2742         }
2743         len = POPi;
2744     }
2745     pos = POPi;
2746     sv = POPs;
2747     PUTBACK;
2748     if (repl_sv) {
2749         if (repl_is_utf8) {
2750             if (!DO_UTF8(sv))
2751                 sv_utf8_upgrade(sv);
2752         }
2753         else if (DO_UTF8(sv))
2754             repl_need_utf8_upgrade = TRUE;
2755     }
2756     tmps = SvPV(sv, curlen);
2757     if (DO_UTF8(sv)) {
2758         utf8_curlen = sv_len_utf8(sv);
2759         if (utf8_curlen == curlen)
2760             utf8_curlen = 0;
2761         else
2762             curlen = utf8_curlen;
2763     }
2764     else
2765         utf8_curlen = 0;
2766
2767     if (pos >= arybase) {
2768         pos -= arybase;
2769         rem = curlen-pos;
2770         fail = rem;
2771         if (num_args > 2) {
2772             if (len < 0) {
2773                 rem += len;
2774                 if (rem < 0)
2775                     rem = 0;
2776             }
2777             else if (rem > len)
2778                      rem = len;
2779         }
2780     }
2781     else {
2782         pos += curlen;
2783         if (num_args < 3)
2784             rem = curlen;
2785         else if (len >= 0) {
2786             rem = pos+len;
2787             if (rem > (I32)curlen)
2788                 rem = curlen;
2789         }
2790         else {
2791             rem = curlen+len;
2792             if (rem < pos)
2793                 rem = pos;
2794         }
2795         if (pos < 0)
2796             pos = 0;
2797         fail = rem;
2798         rem -= pos;
2799     }
2800     if (fail < 0) {
2801         if (lvalue || repl)
2802             Perl_croak(aTHX_ "substr outside of string");
2803         if (ckWARN(WARN_SUBSTR))
2804             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2805         RETPUSHUNDEF;
2806     }
2807     else {
2808         I32 upos = pos;
2809         I32 urem = rem;
2810         if (utf8_curlen)
2811             sv_pos_u2b(sv, &pos, &rem);
2812         tmps += pos;
2813         sv_setpvn(TARG, tmps, rem);
2814 #ifdef USE_LOCALE_COLLATE
2815         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2816 #endif
2817         if (utf8_curlen)
2818             SvUTF8_on(TARG);
2819         if (repl) {
2820             SV* repl_sv_copy = NULL;
2821
2822             if (repl_need_utf8_upgrade) {
2823                 repl_sv_copy = newSVsv(repl_sv);
2824                 sv_utf8_upgrade(repl_sv_copy);
2825                 repl = SvPV(repl_sv_copy, repl_len);
2826                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2827             }
2828             sv_insert(sv, pos, rem, repl, repl_len);
2829             if (repl_is_utf8)
2830                 SvUTF8_on(sv);
2831             if (repl_sv_copy)
2832                 SvREFCNT_dec(repl_sv_copy);
2833         }
2834         else if (lvalue) {              /* it's an lvalue! */
2835             if (!SvGMAGICAL(sv)) {
2836                 if (SvROK(sv)) {
2837                     STRLEN n_a;
2838                     SvPV_force(sv,n_a);
2839                     if (ckWARN(WARN_SUBSTR))
2840                         Perl_warner(aTHX_ WARN_SUBSTR,
2841                                 "Attempt to use reference as lvalue in substr");
2842                 }
2843                 if (SvOK(sv))           /* is it defined ? */
2844                     (void)SvPOK_only_UTF8(sv);
2845                 else
2846                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2847             }
2848
2849             if (SvTYPE(TARG) < SVt_PVLV) {
2850                 sv_upgrade(TARG, SVt_PVLV);
2851                 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2852             }
2853
2854             LvTYPE(TARG) = 'x';
2855             if (LvTARG(TARG) != sv) {
2856                 if (LvTARG(TARG))
2857                     SvREFCNT_dec(LvTARG(TARG));
2858                 LvTARG(TARG) = SvREFCNT_inc(sv);
2859             }
2860             LvTARGOFF(TARG) = upos;
2861             LvTARGLEN(TARG) = urem;
2862         }
2863     }
2864     SPAGAIN;
2865     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2866     RETURN;
2867 }
2868
2869 PP(pp_vec)
2870 {
2871     dSP; dTARGET;
2872     register IV size   = POPi;
2873     register IV offset = POPi;
2874     register SV *src = POPs;
2875     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2876
2877     SvTAINTED_off(TARG);                /* decontaminate */
2878     if (lvalue) {                       /* it's an lvalue! */
2879         if (SvTYPE(TARG) < SVt_PVLV) {
2880             sv_upgrade(TARG, SVt_PVLV);
2881             sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2882         }
2883         LvTYPE(TARG) = 'v';
2884         if (LvTARG(TARG) != src) {
2885             if (LvTARG(TARG))
2886                 SvREFCNT_dec(LvTARG(TARG));
2887             LvTARG(TARG) = SvREFCNT_inc(src);
2888         }
2889         LvTARGOFF(TARG) = offset;
2890         LvTARGLEN(TARG) = size;
2891     }
2892
2893     sv_setuv(TARG, do_vecget(src, offset, size));
2894     PUSHs(TARG);
2895     RETURN;
2896 }
2897
2898 PP(pp_index)
2899 {
2900     dSP; dTARGET;
2901     SV *big;
2902     SV *little;
2903     I32 offset;
2904     I32 retval;
2905     char *tmps;
2906     char *tmps2;
2907     STRLEN biglen;
2908     I32 arybase = PL_curcop->cop_arybase;
2909
2910     if (MAXARG < 3)
2911         offset = 0;
2912     else
2913         offset = POPi - arybase;
2914     little = POPs;
2915     big = POPs;
2916     tmps = SvPV(big, biglen);
2917     if (offset > 0 && DO_UTF8(big))
2918         sv_pos_u2b(big, &offset, 0);
2919     if (offset < 0)
2920         offset = 0;
2921     else if (offset > biglen)
2922         offset = biglen;
2923     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2924       (unsigned char*)tmps + biglen, little, 0)))
2925         retval = -1;
2926     else
2927         retval = tmps2 - tmps;
2928     if (retval > 0 && DO_UTF8(big))
2929         sv_pos_b2u(big, &retval);
2930     PUSHi(retval + arybase);
2931     RETURN;
2932 }
2933
2934 PP(pp_rindex)
2935 {
2936     dSP; dTARGET;
2937     SV *big;
2938     SV *little;
2939     STRLEN blen;
2940     STRLEN llen;
2941     I32 offset;
2942     I32 retval;
2943     char *tmps;
2944     char *tmps2;
2945     I32 arybase = PL_curcop->cop_arybase;
2946
2947     if (MAXARG >= 3)
2948         offset = POPi;
2949     little = POPs;
2950     big = POPs;
2951     tmps2 = SvPV(little, llen);
2952     tmps = SvPV(big, blen);
2953     if (MAXARG < 3)
2954         offset = blen;
2955     else {
2956         if (offset > 0 && DO_UTF8(big))
2957             sv_pos_u2b(big, &offset, 0);
2958         offset = offset - arybase + llen;
2959     }
2960     if (offset < 0)
2961         offset = 0;
2962     else if (offset > blen)
2963         offset = blen;
2964     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2965                           tmps2, tmps2 + llen)))
2966         retval = -1;
2967     else
2968         retval = tmps2 - tmps;
2969     if (retval > 0 && DO_UTF8(big))
2970         sv_pos_b2u(big, &retval);
2971     PUSHi(retval + arybase);
2972     RETURN;
2973 }
2974
2975 PP(pp_sprintf)
2976 {
2977     dSP; dMARK; dORIGMARK; dTARGET;
2978     do_sprintf(TARG, SP-MARK, MARK+1);
2979     TAINT_IF(SvTAINTED(TARG));
2980     SP = ORIGMARK;
2981     PUSHTARG;
2982     RETURN;
2983 }
2984
2985 PP(pp_ord)
2986 {
2987     dSP; dTARGET;
2988     SV *argsv = POPs;
2989     STRLEN len;
2990     U8 *s = (U8*)SvPVx(argsv, len);
2991
2992     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2993     RETURN;
2994 }
2995
2996 PP(pp_chr)
2997 {
2998     dSP; dTARGET;
2999     char *tmps;
3000     UV value = POPu;
3001
3002     (void)SvUPGRADE(TARG,SVt_PV);
3003
3004     if (value > 255 && !IN_BYTE) {
3005         SvGROW(TARG, UNISKIP(value)+1);
3006         tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3007         SvCUR_set(TARG, tmps - SvPVX(TARG));
3008         *tmps = '\0';
3009         (void)SvPOK_only(TARG);
3010         SvUTF8_on(TARG);
3011         XPUSHs(TARG);
3012         RETURN;
3013     }
3014
3015     SvGROW(TARG,2);
3016     SvCUR_set(TARG, 1);
3017     tmps = SvPVX(TARG);
3018     *tmps++ = value;
3019     *tmps = '\0';
3020     (void)SvPOK_only(TARG);
3021     XPUSHs(TARG);
3022     RETURN;
3023 }
3024
3025 PP(pp_crypt)
3026 {
3027     dSP; dTARGET; dPOPTOPssrl;
3028     STRLEN n_a;
3029 #ifdef HAS_CRYPT
3030     char *tmps = SvPV(left, n_a);
3031 #ifdef FCRYPT
3032     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3033 #else
3034     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3035 #endif
3036 #else
3037     DIE(aTHX_
3038       "The crypt() function is unimplemented due to excessive paranoia.");
3039 #endif
3040     SETs(TARG);
3041     RETURN;
3042 }
3043
3044 PP(pp_ucfirst)
3045 {
3046     dSP;
3047     SV *sv = TOPs;
3048     register U8 *s;
3049     STRLEN slen;
3050
3051     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3052         STRLEN ulen;
3053         U8 tmpbuf[UTF8_MAXLEN+1];
3054         U8 *tend;
3055         UV uv;
3056
3057         if (PL_op->op_private & OPpLOCALE) {
3058             TAINT;
3059             SvTAINTED_on(sv);
3060             uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3061         }
3062         else
3063             uv = toTITLE_utf8(s);
3064
3065         tend = uvchr_to_utf8(tmpbuf, uv);
3066
3067         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3068             dTARGET;
3069             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3070             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3071             SvUTF8_on(TARG);
3072             SETs(TARG);
3073         }
3074         else {
3075             s = (U8*)SvPV_force(sv, slen);
3076             Copy(tmpbuf, s, ulen, U8);
3077         }
3078     }
3079     else {
3080         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3081             dTARGET;
3082             SvUTF8_off(TARG);                           /* decontaminate */
3083             sv_setsv(TARG, sv);
3084             sv = TARG;
3085             SETs(sv);
3086         }
3087         s = (U8*)SvPV_force(sv, slen);
3088         if (*s) {
3089             if (PL_op->op_private & OPpLOCALE) {
3090                 TAINT;
3091                 SvTAINTED_on(sv);
3092                 *s = toUPPER_LC(*s);
3093             }
3094             else
3095                 *s = toUPPER(*s);
3096         }
3097     }
3098     if (SvSMAGICAL(sv))
3099         mg_set(sv);
3100     RETURN;
3101 }
3102
3103 PP(pp_lcfirst)
3104 {
3105     dSP;
3106     SV *sv = TOPs;
3107     register U8 *s;
3108     STRLEN slen;
3109
3110     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3111         STRLEN ulen;
3112         U8 tmpbuf[UTF8_MAXLEN+1];
3113         U8 *tend;
3114         UV uv;
3115
3116         if (PL_op->op_private & OPpLOCALE) {
3117             TAINT;
3118             SvTAINTED_on(sv);
3119             uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3120         }
3121         else
3122             uv = toLOWER_utf8(s);
3123
3124         tend = uvchr_to_utf8(tmpbuf, uv);
3125
3126         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3127             dTARGET;
3128             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3129             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3130             SvUTF8_on(TARG);
3131             SETs(TARG);
3132         }
3133         else {
3134             s = (U8*)SvPV_force(sv, slen);
3135             Copy(tmpbuf, s, ulen, U8);
3136         }
3137     }
3138     else {
3139         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3140             dTARGET;
3141             SvUTF8_off(TARG);                           /* decontaminate */
3142             sv_setsv(TARG, sv);
3143             sv = TARG;
3144             SETs(sv);
3145         }
3146         s = (U8*)SvPV_force(sv, slen);
3147         if (*s) {
3148             if (PL_op->op_private & OPpLOCALE) {
3149                 TAINT;
3150                 SvTAINTED_on(sv);
3151                 *s = toLOWER_LC(*s);
3152             }
3153             else
3154                 *s = toLOWER(*s);
3155         }
3156     }
3157     if (SvSMAGICAL(sv))
3158         mg_set(sv);
3159     RETURN;
3160 }
3161
3162 PP(pp_uc)
3163 {
3164     dSP;
3165     SV *sv = TOPs;
3166     register U8 *s;
3167     STRLEN len;
3168
3169     if (DO_UTF8(sv)) {
3170         dTARGET;
3171         STRLEN ulen;
3172         register U8 *d;
3173         U8 *send;
3174
3175         s = (U8*)SvPV(sv,len);
3176         if (!len) {
3177             SvUTF8_off(TARG);                           /* decontaminate */
3178             sv_setpvn(TARG, "", 0);
3179             SETs(TARG);
3180         }
3181         else {
3182             (void)SvUPGRADE(TARG, SVt_PV);
3183             SvGROW(TARG, (len * 2) + 1);
3184             (void)SvPOK_only(TARG);
3185             d = (U8*)SvPVX(TARG);
3186             send = s + len;
3187             if (PL_op->op_private & OPpLOCALE) {
3188                 TAINT;
3189                 SvTAINTED_on(TARG);
3190                 while (s < send) {
3191                     d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3192                     s += ulen;
3193                 }
3194             }
3195             else {
3196                 while (s < send) {
3197                     d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3198                     s += UTF8SKIP(s);
3199                 }
3200             }
3201             *d = '\0';
3202             SvUTF8_on(TARG);
3203             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3204             SETs(TARG);
3205         }
3206     }
3207     else {
3208         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3209             dTARGET;
3210             SvUTF8_off(TARG);                           /* decontaminate */
3211             sv_setsv(TARG, sv);
3212             sv = TARG;
3213             SETs(sv);
3214         }
3215         s = (U8*)SvPV_force(sv, len);
3216         if (len) {
3217             register U8 *send = s + len;
3218
3219             if (PL_op->op_private & OPpLOCALE) {
3220                 TAINT;
3221                 SvTAINTED_on(sv);
3222                 for (; s < send; s++)
3223                     *s = toUPPER_LC(*s);
3224             }
3225             else {
3226                 for (; s < send; s++)
3227                     *s = toUPPER(*s);
3228             }
3229         }
3230     }
3231     if (SvSMAGICAL(sv))
3232         mg_set(sv);
3233     RETURN;
3234 }
3235
3236 PP(pp_lc)
3237 {
3238     dSP;
3239     SV *sv = TOPs;
3240     register U8 *s;
3241     STRLEN len;
3242
3243     if (DO_UTF8(sv)) {
3244         dTARGET;
3245         STRLEN ulen;
3246         register U8 *d;
3247         U8 *send;
3248
3249         s = (U8*)SvPV(sv,len);
3250         if (!len) {
3251             SvUTF8_off(TARG);                           /* decontaminate */
3252             sv_setpvn(TARG, "", 0);
3253             SETs(TARG);
3254         }
3255         else {
3256             (void)SvUPGRADE(TARG, SVt_PV);
3257             SvGROW(TARG, (len * 2) + 1);
3258             (void)SvPOK_only(TARG);
3259             d = (U8*)SvPVX(TARG);
3260             send = s + len;
3261             if (PL_op->op_private & OPpLOCALE) {
3262                 TAINT;
3263                 SvTAINTED_on(TARG);
3264                 while (s < send) {
3265                     d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3266                     s += ulen;
3267                 }
3268             }
3269             else {
3270                 while (s < send) {
3271                     d = uvchr_to_utf8(d, toLOWER_utf8(s));
3272                     s += UTF8SKIP(s);
3273                 }
3274             }
3275             *d = '\0';
3276             SvUTF8_on(TARG);
3277             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3278             SETs(TARG);
3279         }
3280     }
3281     else {
3282         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3283             dTARGET;
3284             SvUTF8_off(TARG);                           /* decontaminate */
3285             sv_setsv(TARG, sv);
3286             sv = TARG;
3287             SETs(sv);
3288         }
3289
3290         s = (U8*)SvPV_force(sv, len);
3291         if (len) {
3292             register U8 *send = s + len;
3293
3294             if (PL_op->op_private & OPpLOCALE) {
3295                 TAINT;
3296                 SvTAINTED_on(sv);
3297                 for (; s < send; s++)
3298                     *s = toLOWER_LC(*s);
3299             }
3300             else {
3301                 for (; s < send; s++)
3302                     *s = toLOWER(*s);
3303             }
3304         }
3305     }
3306     if (SvSMAGICAL(sv))
3307         mg_set(sv);
3308     RETURN;
3309 }
3310
3311 PP(pp_quotemeta)
3312 {
3313     dSP; dTARGET;
3314     SV *sv = TOPs;
3315     STRLEN len;
3316     register char *s = SvPV(sv,len);
3317     register char *d;
3318
3319     SvUTF8_off(TARG);                           /* decontaminate */
3320     if (len) {
3321         (void)SvUPGRADE(TARG, SVt_PV);
3322         SvGROW(TARG, (len * 2) + 1);
3323         d = SvPVX(TARG);
3324         if (DO_UTF8(sv)) {
3325             while (len) {
3326                 if (UTF8_IS_CONTINUED(*s)) {
3327                     STRLEN ulen = UTF8SKIP(s);
3328                     if (ulen > len)
3329                         ulen = len;
3330                     len -= ulen;
3331                     while (ulen--)
3332                         *d++ = *s++;
3333                 }
3334                 else {
3335                     if (!isALNUM(*s))
3336                         *d++ = '\\';
3337                     *d++ = *s++;
3338                     len--;
3339                 }
3340             }
3341             SvUTF8_on(TARG);
3342         }
3343         else {
3344             while (len--) {
3345                 if (!isALNUM(*s))
3346                     *d++ = '\\';
3347                 *d++ = *s++;
3348             }
3349         }
3350         *d = '\0';
3351         SvCUR_set(TARG, d - SvPVX(TARG));
3352         (void)SvPOK_only_UTF8(TARG);
3353     }
3354     else
3355         sv_setpvn(TARG, s, len);
3356     SETs(TARG);
3357     if (SvSMAGICAL(TARG))
3358         mg_set(TARG);
3359     RETURN;
3360 }
3361
3362 /* Arrays. */
3363
3364 PP(pp_aslice)
3365 {
3366     dSP; dMARK; dORIGMARK;
3367     register SV** svp;
3368     register AV* av = (AV*)POPs;
3369     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3370     I32 arybase = PL_curcop->cop_arybase;
3371     I32 elem;
3372
3373     if (SvTYPE(av) == SVt_PVAV) {
3374         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3375             I32 max = -1;
3376             for (svp = MARK + 1; svp <= SP; svp++) {
3377                 elem = SvIVx(*svp);
3378                 if (elem > max)
3379                     max = elem;
3380             }
3381             if (max > AvMAX(av))
3382                 av_extend(av, max);
3383         }
3384         while (++MARK <= SP) {
3385             elem = SvIVx(*MARK);
3386
3387             if (elem > 0)
3388                 elem -= arybase;
3389             svp = av_fetch(av, elem, lval);
3390             if (lval) {
3391                 if (!svp || *svp == &PL_sv_undef)
3392                     DIE(aTHX_ PL_no_aelem, elem);
3393                 if (PL_op->op_private & OPpLVAL_INTRO)
3394                     save_aelem(av, elem, svp);
3395             }
3396             *MARK = svp ? *svp : &PL_sv_undef;
3397         }
3398     }
3399     if (GIMME != G_ARRAY) {
3400         MARK = ORIGMARK;
3401         *++MARK = *SP;
3402         SP = MARK;
3403     }
3404     RETURN;
3405 }
3406
3407 /* Associative arrays. */
3408
3409 PP(pp_each)
3410 {
3411     dSP;
3412     HV *hash = (HV*)POPs;
3413     HE *entry;
3414     I32 gimme = GIMME_V;
3415     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3416
3417     PUTBACK;
3418     /* might clobber stack_sp */
3419     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3420     SPAGAIN;
3421
3422     EXTEND(SP, 2);
3423     if (entry) {
3424         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
3425         if (gimme == G_ARRAY) {
3426             SV *val;
3427             PUTBACK;
3428             /* might clobber stack_sp */
3429             val = realhv ?
3430                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3431             SPAGAIN;
3432             PUSHs(val);
3433         }
3434     }
3435     else if (gimme == G_SCALAR)
3436         RETPUSHUNDEF;
3437
3438     RETURN;
3439 }
3440
3441 PP(pp_values)
3442 {
3443     return do_kv();
3444 }
3445
3446 PP(pp_keys)
3447 {
3448     return do_kv();
3449 }
3450
3451 PP(pp_delete)
3452 {
3453     dSP;
3454     I32 gimme = GIMME_V;
3455     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3456     SV *sv;
3457     HV *hv;
3458
3459     if (PL_op->op_private & OPpSLICE) {
3460         dMARK; dORIGMARK;
3461         U32 hvtype;
3462         hv = (HV*)POPs;
3463         hvtype = SvTYPE(hv);
3464         if (hvtype == SVt_PVHV) {                       /* hash element */
3465             while (++MARK <= SP) {
3466                 sv = hv_delete_ent(hv, *MARK, discard, 0);
3467                 *MARK = sv ? sv : &PL_sv_undef;
3468             }
3469         }
3470         else if (hvtype == SVt_PVAV) {
3471             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
3472                 while (++MARK <= SP) {
3473                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3474                     *MARK = sv ? sv : &PL_sv_undef;
3475                 }
3476             }
3477             else {                                      /* pseudo-hash element */
3478                 while (++MARK <= SP) {
3479                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3480                     *MARK = sv ? sv : &PL_sv_undef;
3481                 }
3482             }
3483         }
3484         else
3485             DIE(aTHX_ "Not a HASH reference");
3486         if (discard)
3487             SP = ORIGMARK;
3488         else if (gimme == G_SCALAR) {
3489             MARK = ORIGMARK;
3490             *++MARK = *SP;
3491             SP = MARK;
3492         }
3493     }
3494     else {
3495         SV *keysv = POPs;
3496         hv = (HV*)POPs;
3497         if (SvTYPE(hv) == SVt_PVHV)
3498             sv = hv_delete_ent(hv, keysv, discard, 0);
3499         else if (SvTYPE(hv) == SVt_PVAV) {
3500             if (PL_op->op_flags & OPf_SPECIAL)
3501                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3502             else
3503                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3504         }
3505         else
3506             DIE(aTHX_ "Not a HASH reference");
3507         if (!sv)
3508             sv = &PL_sv_undef;
3509         if (!discard)
3510             PUSHs(sv);
3511     }
3512     RETURN;
3513 }
3514
3515 PP(pp_exists)
3516 {
3517     dSP;
3518     SV *tmpsv;
3519     HV *hv;
3520
3521     if (PL_op->op_private & OPpEXISTS_SUB) {
3522         GV *gv;
3523         CV *cv;
3524         SV *sv = POPs;
3525         cv = sv_2cv(sv, &hv, &gv, FALSE);
3526         if (cv)
3527             RETPUSHYES;
3528         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3529             RETPUSHYES;
3530         RETPUSHNO;
3531     }
3532     tmpsv = POPs;
3533     hv = (HV*)POPs;
3534     if (SvTYPE(hv) == SVt_PVHV) {
3535         if (hv_exists_ent(hv, tmpsv, 0))
3536             RETPUSHYES;
3537     }
3538     else if (SvTYPE(hv) == SVt_PVAV) {
3539         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
3540             if (av_exists((AV*)hv, SvIV(tmpsv)))
3541                 RETPUSHYES;
3542         }
3543         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
3544             RETPUSHYES;
3545     }
3546     else {
3547         DIE(aTHX_ "Not a HASH reference");
3548     }
3549     RETPUSHNO;
3550 }
3551
3552 PP(pp_hslice)
3553 {
3554     dSP; dMARK; dORIGMARK;
3555     register HV *hv = (HV*)POPs;
3556     register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3557     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3558
3559     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3560         DIE(aTHX_ "Can't localize pseudo-hash element");
3561
3562     if (realhv || SvTYPE(hv) == SVt_PVAV) {
3563         while (++MARK <= SP) {
3564             SV *keysv = *MARK;
3565             SV **svp;
3566             I32 preeminent = SvRMAGICAL(hv) ? 1 :
3567                                 realhv ? hv_exists_ent(hv, keysv, 0)
3568                                        : avhv_exists_ent((AV*)hv, keysv, 0);
3569             if (realhv) {
3570                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3571                 svp = he ? &HeVAL(he) : 0;
3572             }
3573             else {
3574                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3575             }
3576             if (lval) {
3577                 if (!svp || *svp == &PL_sv_undef) {
3578                     STRLEN n_a;
3579                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3580                 }
3581                 if (PL_op->op_private & OPpLVAL_INTRO) {
3582                     if (preeminent)
3583                         save_helem(hv, keysv, svp);
3584                     else {
3585                         STRLEN keylen;
3586                         char *key = SvPV(keysv, keylen);
3587                         SAVEDELETE(hv, savepvn(key,keylen), keylen);
3588                     }
3589                 }
3590             }
3591             *MARK = svp ? *svp : &PL_sv_undef;
3592         }
3593     }
3594     if (GIMME != G_ARRAY) {
3595         MARK = ORIGMARK;
3596         *++MARK = *SP;
3597         SP = MARK;
3598     }
3599     RETURN;
3600 }
3601
3602 /* List operators. */
3603
3604 PP(pp_list)
3605 {
3606     dSP; dMARK;
3607     if (GIMME != G_ARRAY) {
3608         if (++MARK <= SP)
3609             *MARK = *SP;                /* unwanted list, return last item */
3610         else
3611             *MARK = &PL_sv_undef;
3612         SP = MARK;
3613     }
3614     RETURN;
3615 }
3616
3617 PP(pp_lslice)
3618 {
3619     dSP;
3620     SV **lastrelem = PL_stack_sp;
3621     SV **lastlelem = PL_stack_base + POPMARK;
3622     SV **firstlelem = PL_stack_base + POPMARK + 1;
3623     register SV **firstrelem = lastlelem + 1;
3624     I32 arybase = PL_curcop->cop_arybase;
3625     I32 lval = PL_op->op_flags & OPf_MOD;
3626     I32 is_something_there = lval;
3627
3628     register I32 max = lastrelem - lastlelem;
3629     register SV **lelem;
3630     register I32 ix;
3631
3632     if (GIMME != G_ARRAY) {
3633         ix = SvIVx(*lastlelem);
3634         if (ix < 0)
3635             ix += max;
3636         else
3637             ix -= arybase;
3638         if (ix < 0 || ix >= max)
3639             *firstlelem = &PL_sv_undef;
3640         else
3641             *firstlelem = firstrelem[ix];
3642         SP = firstlelem;
3643         RETURN;
3644     }
3645
3646     if (max == 0) {
3647         SP = firstlelem - 1;
3648         RETURN;
3649     }
3650
3651     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3652         ix = SvIVx(*lelem);
3653         if (ix < 0)
3654             ix += max;
3655         else
3656             ix -= arybase;
3657         if (ix < 0 || ix >= max)
3658             *lelem = &PL_sv_undef;
3659         else {
3660             is_something_there = TRUE;
3661             if (!(*lelem = firstrelem[ix]))
3662                 *lelem = &PL_sv_undef;
3663         }
3664     }
3665     if (is_something_there)
3666         SP = lastlelem;
3667     else
3668         SP = firstlelem - 1;
3669     RETURN;
3670 }
3671
3672 PP(pp_anonlist)
3673 {
3674     dSP; dMARK; dORIGMARK;
3675     I32 items = SP - MARK;
3676     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3677     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
3678     XPUSHs(av);
3679     RETURN;
3680 }
3681
3682 PP(pp_anonhash)
3683 {
3684     dSP; dMARK; dORIGMARK;
3685     HV* hv = (HV*)sv_2mortal((SV*)newHV());
3686
3687     while (MARK < SP) {
3688         SV* key = *++MARK;
3689         SV *val = NEWSV(46, 0);
3690         if (MARK < SP)
3691             sv_setsv(val, *++MARK);
3692         else if (ckWARN(WARN_MISC))
3693             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3694         (void)hv_store_ent(hv,key,val,0);
3695     }
3696     SP = ORIGMARK;
3697     XPUSHs((SV*)hv);
3698     RETURN;
3699 }
3700
3701 PP(pp_splice)
3702 {
3703     dSP; dMARK; dORIGMARK;
3704     register AV *ary = (AV*)*++MARK;
3705     register SV **src;
3706     register SV **dst;
3707     register I32 i;
3708     register I32 offset;
3709     register I32 length;
3710     I32 newlen;
3711     I32 after;
3712     I32 diff;
3713     SV **tmparyval = 0;
3714     MAGIC *mg;
3715
3716     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3717         *MARK-- = SvTIED_obj((SV*)ary, mg);
3718         PUSHMARK(MARK);
3719         PUTBACK;
3720         ENTER;
3721         call_method("SPLICE",GIMME_V);
3722         LEAVE;
3723         SPAGAIN;
3724         RETURN;
3725     }
3726
3727     SP++;
3728
3729     if (++MARK < SP) {
3730         offset = i = SvIVx(*MARK);
3731         if (offset < 0)
3732             offset += AvFILLp(ary) + 1;
3733         else
3734             offset -= PL_curcop->cop_arybase;
3735         if (offset < 0)
3736             DIE(aTHX_ PL_no_aelem, i);
3737         if (++MARK < SP) {
3738             length = SvIVx(*MARK++);
3739             if (length < 0) {
3740                 length += AvFILLp(ary) - offset + 1;
3741                 if (length < 0)
3742                     length = 0;
3743             }
3744         }
3745         else
3746             length = AvMAX(ary) + 1;            /* close enough to infinity */
3747     }
3748     else {
3749         offset = 0;
3750         length = AvMAX(ary) + 1;
3751     }
3752     if (offset > AvFILLp(ary) + 1)
3753         offset = AvFILLp(ary) + 1;
3754     after = AvFILLp(ary) + 1 - (offset + length);
3755     if (after < 0) {                            /* not that much array */
3756         length += after;                        /* offset+length now in array */
3757         after = 0;
3758         if (!AvALLOC(ary))
3759             av_extend(ary, 0);
3760     }
3761
3762     /* At this point, MARK .. SP-1 is our new LIST */
3763
3764     newlen = SP - MARK;
3765     diff = newlen - length;
3766     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3767         av_reify(ary);
3768
3769     if (diff < 0) {                             /* shrinking the area */
3770         if (newlen) {
3771             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3772             Copy(MARK, tmparyval, newlen, SV*);
3773         }
3774
3775         MARK = ORIGMARK + 1;
3776         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3777             MEXTEND(MARK, length);
3778             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3779             if (AvREAL(ary)) {
3780                 EXTEND_MORTAL(length);
3781                 for (i = length, dst = MARK; i; i--) {
3782                     sv_2mortal(*dst);   /* free them eventualy */
3783                     dst++;
3784                 }
3785             }
3786             MARK += length - 1;
3787         }
3788         else {
3789             *MARK = AvARRAY(ary)[offset+length-1];
3790             if (AvREAL(ary)) {
3791                 sv_2mortal(*MARK);
3792                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3793                     SvREFCNT_dec(*dst++);       /* free them now */
3794             }
3795         }
3796         AvFILLp(ary) += diff;
3797
3798         /* pull up or down? */
3799
3800         if (offset < after) {                   /* easier to pull up */
3801             if (offset) {                       /* esp. if nothing to pull */
3802                 src = &AvARRAY(ary)[offset-1];
3803                 dst = src - diff;               /* diff is negative */
3804                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3805                     *dst-- = *src--;
3806             }
3807             dst = AvARRAY(ary);
3808             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3809             AvMAX(ary) += diff;
3810         }
3811         else {
3812             if (after) {                        /* anything to pull down? */
3813                 src = AvARRAY(ary) + offset + length;
3814                 dst = src + diff;               /* diff is negative */
3815                 Move(src, dst, after, SV*);
3816             }
3817             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3818                                                 /* avoid later double free */
3819         }
3820         i = -diff;
3821         while (i)
3822             dst[--i] = &PL_sv_undef;
3823
3824         if (newlen) {
3825             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3826               newlen; newlen--) {
3827                 *dst = NEWSV(46, 0);
3828                 sv_setsv(*dst++, *src++);
3829             }
3830             Safefree(tmparyval);
3831         }
3832     }
3833     else {                                      /* no, expanding (or same) */
3834         if (length) {
3835             New(452, tmparyval, length, SV*);   /* so remember deletion */
3836             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3837         }
3838
3839         if (diff > 0) {                         /* expanding */
3840
3841             /* push up or down? */
3842
3843             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3844                 if (offset) {
3845                     src = AvARRAY(ary);
3846                     dst = src - diff;
3847                     Move(src, dst, offset, SV*);
3848                 }
3849                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3850                 AvMAX(ary) += diff;
3851                 AvFILLp(ary) += diff;
3852             }
3853             else {
3854                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3855                     av_extend(ary, AvFILLp(ary) + diff);
3856                 AvFILLp(ary) += diff;
3857
3858                 if (after) {
3859                     dst = AvARRAY(ary) + AvFILLp(ary);
3860                     src = dst - diff;
3861                     for (i = after; i; i--) {
3862                         *dst-- = *src--;
3863                     }
3864                 }
3865             }
3866         }
3867
3868         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3869             *dst = NEWSV(46, 0);
3870             sv_setsv(*dst++, *src++);
3871         }
3872         MARK = ORIGMARK + 1;
3873         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3874             if (length) {
3875                 Copy(tmparyval, MARK, length, SV*);
3876                 if (AvREAL(ary)) {
3877                     EXTEND_MORTAL(length);
3878                     for (i = length, dst = MARK; i; i--) {
3879                         sv_2mortal(*dst);       /* free them eventualy */
3880                         dst++;
3881                     }
3882                 }
3883                 Safefree(tmparyval);
3884             }
3885             MARK += length - 1;
3886         }
3887         else if (length--) {
3888             *MARK = tmparyval[length];
3889             if (AvREAL(ary)) {
3890                 sv_2mortal(*MARK);
3891                 while (length-- > 0)
3892                     SvREFCNT_dec(tmparyval[length]);
3893             }
3894             Safefree(tmparyval);
3895         }
3896         else
3897             *MARK = &PL_sv_undef;
3898     }
3899     SP = MARK;
3900     RETURN;
3901 }
3902
3903 PP(pp_push)
3904 {
3905     dSP; dMARK; dORIGMARK; dTARGET;
3906     register AV *ary = (AV*)*++MARK;
3907     register SV *sv = &PL_sv_undef;
3908     MAGIC *mg;
3909
3910     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3911         *MARK-- = SvTIED_obj((SV*)ary, mg);
3912         PUSHMARK(MARK);
3913         PUTBACK;
3914         ENTER;
3915         call_method("PUSH",G_SCALAR|G_DISCARD);
3916         LEAVE;
3917         SPAGAIN;
3918     }
3919     else {
3920         /* Why no pre-extend of ary here ? */
3921         for (++MARK; MARK <= SP; MARK++) {
3922             sv = NEWSV(51, 0);
3923             if (*MARK)
3924                 sv_setsv(sv, *MARK);
3925             av_push(ary, sv);
3926         }
3927     }
3928     SP = ORIGMARK;
3929     PUSHi( AvFILL(ary) + 1 );
3930     RETURN;
3931 }
3932
3933 PP(pp_pop)
3934 {
3935     dSP;
3936     AV *av = (AV*)POPs;
3937     SV *sv = av_pop(av);
3938     if (AvREAL(av))
3939         (void)sv_2mortal(sv);
3940     PUSHs(sv);
3941     RETURN;
3942 }
3943
3944 PP(pp_shift)
3945 {
3946     dSP;
3947     AV *av = (AV*)POPs;
3948     SV *sv = av_shift(av);
3949     EXTEND(SP, 1);
3950     if (!sv)
3951         RETPUSHUNDEF;
3952     if (AvREAL(av))
3953         (void)sv_2mortal(sv);
3954     PUSHs(sv);
3955     RETURN;
3956 }
3957
3958 PP(pp_unshift)
3959 {
3960     dSP; dMARK; dORIGMARK; dTARGET;
3961     register AV *ary = (AV*)*++MARK;
3962     register SV *sv;
3963     register I32 i = 0;
3964     MAGIC *mg;
3965
3966     if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3967         *MARK-- = SvTIED_obj((SV*)ary, mg);
3968         PUSHMARK(MARK);
3969         PUTBACK;
3970         ENTER;
3971         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3972         LEAVE;
3973         SPAGAIN;
3974     }
3975     else {
3976         av_unshift(ary, SP - MARK);
3977         while (MARK < SP) {
3978             sv = NEWSV(27, 0);
3979             sv_setsv(sv, *++MARK);
3980             (void)av_store(ary, i++, sv);
3981         }
3982     }
3983     SP = ORIGMARK;
3984     PUSHi( AvFILL(ary) + 1 );
3985     RETURN;
3986 }
3987
3988 PP(pp_reverse)
3989 {
3990     dSP; dMARK;
3991     register SV *tmp;
3992     SV **oldsp = SP;
3993
3994     if (GIMME == G_ARRAY) {
3995         MARK++;
3996         while (MARK < SP) {
3997             tmp = *MARK;
3998             *MARK++ = *SP;
3999             *SP-- = tmp;
4000         }
4001         /* safe as long as stack cannot get extended in the above */
4002         SP = oldsp;
4003     }
4004     else {
4005         register char *up;
4006         register char *down;
4007         register I32 tmp;
4008         dTARGET;
4009         STRLEN len;
4010
4011         SvUTF8_off(TARG);                               /* decontaminate */
4012         if (SP - MARK > 1)
4013             do_join(TARG, &PL_sv_no, MARK, SP);
4014         else
4015             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4016         up = SvPV_force(TARG, len);
4017         if (len > 1) {
4018             if (DO_UTF8(TARG)) {        /* first reverse each character */
4019                 U8* s = (U8*)SvPVX(TARG);
4020                 U8* send = (U8*)(s + len);
4021                 while (s < send) {
4022                     if (UTF8_IS_INVARIANT(*s)) {
4023                         s++;
4024                         continue;
4025                     }
4026                     else {
4027                         if (!utf8_to_uvchr(s, 0))
4028                             break;
4029                         up = (char*)s;
4030                         s += UTF8SKIP(s);
4031                         down = (char*)(s - 1);
4032                         /* reverse this character */
4033                         while (down > up) {
4034                             tmp = *up;
4035                             *up++ = *down;
4036                             *down-- = tmp;
4037                         }
4038                     }
4039                 }
4040                 up = SvPVX(TARG);
4041             }
4042             down = SvPVX(TARG) + len - 1;
4043             while (down > up) {
4044                 tmp = *up;
4045                 *up++ = *down;
4046                 *down-- = tmp;
4047             }
4048             (void)SvPOK_only_UTF8(TARG);
4049         }
4050         SP = MARK + 1;
4051         SETTARG;
4052     }
4053     RETURN;
4054 }
4055
4056 STATIC SV *
4057 S_mul128(pTHX_ SV *sv, U8 m)
4058 {
4059   STRLEN          len;
4060   char           *s = SvPV(sv, len);
4061   char           *t;
4062   U32             i = 0;
4063
4064   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
4065     SV             *tmpNew = newSVpvn("0000000000", 10);
4066
4067     sv_catsv(tmpNew, sv);
4068     SvREFCNT_dec(sv);           /* free old sv */
4069     sv = tmpNew;
4070     s = SvPV(sv, len);
4071   }
4072   t = s + len - 1;
4073   while (!*t)                   /* trailing '\0'? */
4074     t--;
4075   while (t > s) {
4076     i = ((*t - '0') << 7) + m;
4077     *(t--) = '0' + (i % 10);
4078     m = i / 10;
4079   }
4080   return (sv);
4081 }
4082
4083 /* Explosives and implosives. */
4084
4085 #if 'I' == 73 && 'J' == 74
4086 /* On an ASCII/ISO kind of system */
4087 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
4088 #else
4089 /*
4090   Some other sort of character set - use memchr() so we don't match
4091   the null byte.
4092  */
4093 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4094 #endif
4095
4096
4097 PP(pp_unpack)
4098 {
4099     dSP;
4100     dPOPPOPssrl;
4101     I32 start_sp_offset = SP - PL_stack_base;
4102     I32 gimme = GIMME_V;
4103     SV *sv;
4104     STRLEN llen;
4105     STRLEN rlen;
4106     register char *pat = SvPV(left, llen);
4107 #ifdef PACKED_IS_OCTETS
4108     /* Packed side is assumed to be octets - so force downgrade if it
4109        has been UTF-8 encoded by accident
4110      */
4111     register char *s = SvPVbyte(right, rlen);
4112 #else
4113     register char *s = SvPV(right, rlen);
4114 #endif
4115     char *strend = s + rlen;
4116     char *strbeg = s;
4117     register char *patend = pat + llen;
4118     I32 datumtype;
4119     register I32 len;
4120     register I32 bits;
4121     register char *str;
4122
4123     /* These must not be in registers: */
4124     short ashort;
4125     int aint;
4126     long along;
4127 #ifdef HAS_QUAD
4128     Quad_t aquad;
4129 #endif
4130     U16 aushort;
4131     unsigned int auint;
4132     U32 aulong;
4133 #ifdef HAS_QUAD
4134     Uquad_t auquad;
4135 #endif
4136     char *aptr;
4137     float afloat;
4138     double adouble;
4139     I32 checksum = 0;
4140     register U32 culong;
4141     NV cdouble;
4142     int commas = 0;
4143     int star;
4144 #ifdef PERL_NATINT_PACK
4145     int natint;         /* native integer */
4146     int unatint;        /* unsigned native integer */
4147 #endif
4148
4149     if (gimme != G_ARRAY) {             /* arrange to do first one only */
4150         /*SUPPRESS 530*/
4151         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4152         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4153             patend++;
4154             while (isDIGIT(*patend) || *patend == '*')
4155                 patend++;
4156         }
4157         else
4158             patend++;
4159     }
4160     while (pat < patend) {
4161       reparse:
4162         datumtype = *pat++ & 0xFF;
4163 #ifdef PERL_NATINT_PACK
4164         natint = 0;
4165 #endif
4166         if (isSPACE(datumtype))
4167             continue;
4168         if (datumtype == '#') {
4169             while (pat < patend && *pat != '\n')
4170                 pat++;
4171             continue;
4172         }
4173         if (*pat == '!') {
4174             char *natstr = "sSiIlL";
4175
4176             if (strchr(natstr, datumtype)) {
4177 #ifdef PERL_NATINT_PACK
4178                 natint = 1;
4179 #endif
4180                 pat++;
4181             }
4182             else
4183                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4184         }
4185         star = 0;
4186         if (pat >= patend)
4187             len = 1;
4188         else if (*pat == '*') {
4189             len = strend - strbeg;      /* long enough */
4190             pat++;
4191             star = 1;
4192         }
4193         else if (isDIGIT(*pat)) {
4194             len = *pat++ - '0';
4195             while (isDIGIT(*pat)) {
4196                 len = (len * 10) + (*pat++ - '0');
4197                 if (len < 0)
4198                     DIE(aTHX_ "Repeat count in unpack overflows");
4199             }
4200         }
4201         else
4202             len = (datumtype != '@');
4203       redo_switch:
4204         switch(datumtype) {
4205         default:
4206             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4207         case ',': /* grandfather in commas but with a warning */
4208             if (commas++ == 0 && ckWARN(WARN_UNPACK))
4209                 Perl_warner(aTHX_ WARN_UNPACK,
4210                             "Invalid type in unpack: '%c'", (int)datumtype);
4211             break;
4212         case '%':
4213             if (len == 1 && pat[-1] != '1')
4214                 len = 16;
4215             checksum = len;
4216             culong = 0;
4217             cdouble = 0;
4218             if (pat < patend)
4219                 goto reparse;
4220             break;
4221         case '@':
4222             if (len > strend - strbeg)
4223                 DIE(aTHX_ "@ outside of string");
4224             s = strbeg + len;
4225             break;
4226         case 'X':
4227             if (len > s - strbeg)
4228                 DIE(aTHX_ "X outside of string");
4229             s -= len;
4230             break;
4231         case 'x':
4232             if (len > strend - s)
4233                 DIE(aTHX_ "x outside of string");
4234             s += len;
4235             break;
4236         case '/':
4237             if (start_sp_offset >= SP - PL_stack_base)
4238                 DIE(aTHX_ "/ must follow a numeric type");
4239             datumtype = *pat++;
4240             if (*pat == '*')
4241                 pat++;          /* ignore '*' for compatibility with pack */
4242             if (isDIGIT(*pat))
4243                 DIE(aTHX_ "/ cannot take a count" );
4244             len = POPi;
4245             star = 0;
4246             goto redo_switch;
4247         case 'A':
4248         case 'Z':
4249         case 'a':
4250             if (len > strend - s)
4251                 len = strend - s;
4252             if (checksum)
4253                 goto uchar_checksum;
4254             sv = NEWSV(35, len);
4255             sv_setpvn(sv, s, len);
4256             s += len;
4257             if (datumtype == 'A' || datumtype == 'Z') {
4258                 aptr = s;       /* borrow register */
4259                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4260                     s = SvPVX(sv);
4261                     while (*s)
4262                         s++;
4263                 }
4264                 else {          /* 'A' strips both nulls and spaces */
4265                     s = SvPVX(sv) + len - 1;
4266                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4267                         s--;
4268                     *++s = '\0';
4269                 }
4270                 SvCUR_set(sv, s - SvPVX(sv));
4271                 s = aptr;       /* unborrow register */
4272             }
4273             XPUSHs(sv_2mortal(sv));
4274             break;
4275         case 'B':
4276         case 'b':
4277             if (star || len > (strend - s) * 8)
4278                 len = (strend - s) * 8;
4279             if (checksum) {
4280                 if (!PL_bitcount) {
4281                     Newz(601, PL_bitcount, 256, char);
4282                     for (bits = 1; bits < 256; bits++) {
4283                         if (bits & 1)   PL_bitcount[bits]++;
4284                         if (bits & 2)   PL_bitcount[bits]++;
4285                         if (bits & 4)   PL_bitcount[bits]++;
4286                         if (bits & 8)   PL_bitcount[bits]++;
4287                         if (bits & 16)  PL_bitcount[bits]++;
4288                         if (bits & 32)  PL_bitcount[bits]++;
4289                         if (bits & 64)  PL_bitcount[bits]++;
4290                         if (bits & 128) PL_bitcount[bits]++;
4291                     }
4292                 }
4293                 while (len >= 8) {
4294                     culong += PL_bitcount[*(unsigned char*)s++];
4295                     len -= 8;
4296                 }
4297                 if (len) {
4298                     bits = *s;
4299                     if (datumtype == 'b') {
4300                         while (len-- > 0) {
4301                             if (bits & 1) culong++;
4302                             bits >>= 1;
4303                         }
4304                     }
4305                     else {
4306                         while (len-- > 0) {
4307                             if (bits & 128) culong++;
4308                             bits <<= 1;
4309                         }
4310                     }
4311                 }
4312                 break;
4313             }
4314             sv = NEWSV(35, len + 1);
4315             SvCUR_set(sv, len);
4316             SvPOK_on(sv);
4317             str = SvPVX(sv);
4318             if (datumtype == 'b') {
4319                 aint = len;
4320                 for (len = 0; len < aint; len++) {
4321                     if (len & 7)                /*SUPPRESS 595*/
4322                         bits >>= 1;
4323                     else
4324                         bits = *s++;
4325                     *str++ = '0' + (bits & 1);
4326                 }
4327             }
4328             else {
4329                 aint = len;
4330                 for (len = 0; len < aint; len++) {
4331                     if (len & 7)
4332                         bits <<= 1;
4333                     else
4334                         bits = *s++;
4335                     *str++ = '0' + ((bits & 128) != 0);
4336                 }
4337             }
4338             *str = '\0';
4339             XPUSHs(sv_2mortal(sv));
4340             break;
4341         case 'H':
4342         case 'h':
4343             if (star || len > (strend - s) * 2)
4344                 len = (strend - s) * 2;
4345             sv = NEWSV(35, len + 1);
4346             SvCUR_set(sv, len);
4347             SvPOK_on(sv);
4348             str = SvPVX(sv);
4349             if (datumtype == 'h') {
4350                 aint = len;
4351                 for (len = 0; len < aint; len++) {
4352                     if (len & 1)
4353                         bits >>= 4;
4354                     else
4355                         bits = *s++;
4356                     *str++ = PL_hexdigit[bits & 15];
4357                 }
4358             }
4359             else {
4360                 aint = len;
4361                 for (len = 0; len < aint; len++) {
4362                     if (len & 1)
4363                         bits <<= 4;
4364                     else
4365                         bits = *s++;
4366                     *str++ = PL_hexdigit[(bits >> 4) & 15];
4367                 }
4368             }
4369             *str = '\0';
4370             XPUSHs(sv_2mortal(sv));
4371             break;
4372         case 'c':
4373             if (len > strend - s)
4374                 len = strend - s;
4375             if (checksum) {
4376                 while (len-- > 0) {
4377                     aint = *s++;
4378                     if (aint >= 128)    /* fake up signed chars */
4379                         aint -= 256;
4380                     culong += aint;
4381                 }
4382             }
4383             else {
4384                 EXTEND(SP, len);
4385                 EXTEND_MORTAL(len);
4386                 while (len-- > 0) {
4387                     aint = *s++;
4388                     if (aint >= 128)    /* fake up signed chars */
4389                         aint -= 256;
4390                     sv = NEWSV(36, 0);
4391                     sv_setiv(sv, (IV)aint);
4392                     PUSHs(sv_2mortal(sv));
4393                 }
4394             }
4395             break;
4396         case 'C':
4397             if (len > strend - s)
4398                 len = strend - s;
4399             if (checksum) {
4400               uchar_checksum:
4401                 while (len-- > 0) {
4402                     auint = *s++ & 255;
4403                     culong += auint;
4404                 }
4405             }
4406             else {
4407                 EXTEND(SP, len);
4408                 EXTEND_MORTAL(len);
4409                 while (len-- > 0) {
4410                     auint = *s++ & 255;
4411                     sv = NEWSV(37, 0);
4412                     sv_setiv(sv, (IV)auint);
4413                     PUSHs(sv_2mortal(sv));
4414                 }
4415             }
4416             break;
4417         case 'U':
4418             if (len > strend - s)
4419                 len = strend - s;
4420             if (checksum) {
4421                 while (len-- > 0 && s < strend) {
4422                     STRLEN alen;
4423                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4424                     along = alen;
4425                     s += along;
4426                     if (checksum > 32)
4427                         cdouble += (NV)auint;
4428                     else
4429                         culong += auint;
4430                 }
4431             }
4432             else {
4433                 EXTEND(SP, len);
4434                 EXTEND_MORTAL(len);
4435                 while (len-- > 0 && s < strend) {
4436                     STRLEN alen;
4437                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4438                     along = alen;
4439                     s += along;
4440                     sv = NEWSV(37, 0);
4441                     sv_setuv(sv, (UV)auint);
4442                     PUSHs(sv_2mortal(sv));
4443                 }
4444             }
4445             break;
4446         case 's':
4447 #if SHORTSIZE == SIZE16
4448             along = (strend - s) / SIZE16;
4449 #else
4450             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4451 #endif
4452             if (len > along)
4453                 len = along;
4454             if (checksum) {
4455 #if SHORTSIZE != SIZE16
4456                 if (natint) {
4457                     short ashort;
4458                     while (len-- > 0) {
4459                         COPYNN(s, &ashort, sizeof(short));
4460                         s += sizeof(short);
4461                         culong += ashort;
4462
4463                     }
4464                 }
4465                 else
4466 #endif
4467                 {
4468                     while (len-- > 0) {
4469                         COPY16(s, &ashort);
4470 #if SHORTSIZE > SIZE16
4471                         if (ashort > 32767)
4472                           ashort -= 65536;
4473 #endif
4474                         s += SIZE16;
4475                         culong += ashort;
4476                     }
4477                 }
4478             }
4479             else {
4480                 EXTEND(SP, len);
4481                 EXTEND_MORTAL(len);
4482 #if SHORTSIZE != SIZE16
4483                 if (natint) {
4484                     short ashort;
4485                     while (len-- > 0) {
4486                         COPYNN(s, &ashort, sizeof(short));
4487                         s += sizeof(short);
4488                         sv = NEWSV(38, 0);
4489                         sv_setiv(sv, (IV)ashort);
4490                         PUSHs(sv_2mortal(sv));
4491                     }
4492                 }
4493                 else
4494 #endif
4495                 {
4496                     while (len-- > 0) {
4497                         COPY16(s, &ashort);
4498 #if SHORTSIZE > SIZE16
4499                         if (ashort > 32767)
4500                           ashort -= 65536;
4501 #endif
4502                         s += SIZE16;
4503                         sv = NEWSV(38, 0);
4504                         sv_setiv(sv, (IV)ashort);
4505                         PUSHs(sv_2mortal(sv));
4506                     }
4507                 }
4508             }
4509             break;
4510         case 'v':
4511         case 'n':
4512         case 'S':
4513 #if SHORTSIZE == SIZE16
4514             along = (strend - s) / SIZE16;
4515 #else
4516             unatint = natint && datumtype == 'S';
4517             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4518 #endif
4519             if (len > along)
4520                 len = along;
4521             if (checksum) {
4522 #if SHORTSIZE != SIZE16
4523                 if (unatint) {
4524                     unsigned short aushort;
4525                     while (len-- > 0) {
4526                         COPYNN(s, &aushort, sizeof(unsigned short));
4527                         s += sizeof(unsigned short);
4528                         culong += aushort;
4529                     }
4530                 }
4531                 else
4532 #endif
4533                 {
4534                     while (len-- > 0) {
4535                         COPY16(s, &aushort);
4536                         s += SIZE16;
4537 #ifdef HAS_NTOHS
4538                         if (datumtype == 'n')
4539                             aushort = PerlSock_ntohs(aushort);
4540 #endif
4541 #ifdef HAS_VTOHS
4542                         if (datumtype == 'v')
4543                             aushort = vtohs(aushort);
4544 #endif
4545                         culong += aushort;
4546                     }
4547                 }
4548             }
4549             else {
4550                 EXTEND(SP, len);
4551                 EXTEND_MORTAL(len);
4552 #if SHORTSIZE != SIZE16
4553                 if (unatint) {
4554                     unsigned short aushort;
4555                     while (len-- > 0) {
4556                         COPYNN(s, &aushort, sizeof(unsigned short));
4557                         s += sizeof(unsigned short);
4558                         sv = NEWSV(39, 0);
4559                         sv_setiv(sv, (UV)aushort);
4560                         PUSHs(sv_2mortal(sv));
4561                     }
4562                 }
4563                 else
4564 #endif
4565                 {
4566                     while (len-- > 0) {
4567                         COPY16(s, &aushort);
4568                         s += SIZE16;
4569                         sv = NEWSV(39, 0);
4570 #ifdef HAS_NTOHS
4571                         if (datumtype == 'n')
4572                             aushort = PerlSock_ntohs(aushort);
4573 #endif
4574 #ifdef HAS_VTOHS
4575                         if (datumtype == 'v')
4576                             aushort = vtohs(aushort);
4577 #endif
4578                         sv_setiv(sv, (UV)aushort);
4579                         PUSHs(sv_2mortal(sv));
4580                     }
4581                 }
4582             }
4583             break;
4584         case 'i':
4585             along = (strend - s) / sizeof(int);
4586             if (len > along)
4587                 len = along;
4588             if (checksum) {
4589                 while (len-- > 0) {
4590                     Copy(s, &aint, 1, int);
4591                     s += sizeof(int);
4592                     if (checksum > 32)
4593                         cdouble += (NV)aint;
4594                     else
4595                         culong += aint;
4596                 }
4597             }
4598             else {
4599                 EXTEND(SP, len);
4600                 EXTEND_MORTAL(len);
4601                 while (len-- > 0) {
4602                     Copy(s, &aint, 1, int);
4603                     s += sizeof(int);
4604                     sv = NEWSV(40, 0);
4605 #ifdef __osf__
4606                     /* Without the dummy below unpack("i", pack("i",-1))
4607                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4608                      * cc with optimization turned on.
4609                      *
4610                      * The bug was detected in
4611                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4612                      * with optimization (-O4) turned on.
4613                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4614                      * does not have this problem even with -O4.
4615                      *
4616                      * This bug was reported as DECC_BUGS 1431
4617                      * and tracked internally as GEM_BUGS 7775.
4618                      *
4619                      * The bug is fixed in
4620                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
4621                      * UNIX V4.0F support:   DEC C V5.9-006 or later
4622                      * UNIX V4.0E support:   DEC C V5.8-011 or later
4623                      * and also in DTK.
4624                      *
4625                      * See also few lines later for the same bug.
4626                      */
4627                     (aint) ?
4628                         sv_setiv(sv, (IV)aint) :
4629 #endif
4630                     sv_setiv(sv, (IV)aint);
4631                     PUSHs(sv_2mortal(sv));
4632                 }
4633             }
4634             break;
4635         case 'I':
4636             along = (strend - s) / sizeof(unsigned int);
4637             if (len > along)
4638                 len = along;
4639             if (checksum) {
4640                 while (len-- > 0) {
4641                     Copy(s, &auint, 1, unsigned int);
4642                     s += sizeof(unsigned int);
4643                     if (checksum > 32)
4644                         cdouble += (NV)auint;
4645                     else
4646                         culong += auint;
4647                 }
4648             }
4649             else {
4650                 EXTEND(SP, len);
4651                 EXTEND_MORTAL(len);
4652                 while (len-- > 0) {
4653                     Copy(s, &auint, 1, unsigned int);
4654                     s += sizeof(unsigned int);
4655                     sv = NEWSV(41, 0);
4656 #ifdef __osf__
4657                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4658                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4659                      * See details few lines earlier. */
4660                     (auint) ?
4661                         sv_setuv(sv, (UV)auint) :
4662 #endif
4663                     sv_setuv(sv, (UV)auint);
4664                     PUSHs(sv_2mortal(sv));
4665                 }
4666             }
4667             break;
4668         case 'l':
4669 #if LONGSIZE == SIZE32
4670             along = (strend - s) / SIZE32;
4671 #else
4672             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4673 #endif
4674             if (len > along)
4675                 len = along;
4676             if (checksum) {
4677 #if LONGSIZE != SIZE32
4678                 if (natint) {
4679                     while (len-- > 0) {
4680                         COPYNN(s, &along, sizeof(long));
4681                         s += sizeof(long);
4682                         if (checksum > 32)
4683                             cdouble += (NV)along;
4684                         else
4685                             culong += along;
4686                     }
4687                 }
4688                 else
4689 #endif
4690                 {
4691                     while (len-- > 0) {
4692 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4693                         I32 along;
4694 #endif
4695                         COPY32(s, &along);
4696 #if LONGSIZE > SIZE32
4697                         if (along > 2147483647)
4698                           along -= 4294967296;
4699 #endif
4700                         s += SIZE32;
4701                         if (checksum > 32)
4702                             cdouble += (NV)along;
4703                         else
4704                             culong += along;
4705                     }
4706                 }
4707             }
4708             else {
4709                 EXTEND(SP, len);
4710                 EXTEND_MORTAL(len);
4711 #if LONGSIZE != SIZE32
4712                 if (natint) {
4713                     while (len-- > 0) {
4714                         COPYNN(s, &along, sizeof(long));
4715                         s += sizeof(long);
4716                         sv = NEWSV(42, 0);
4717                         sv_setiv(sv, (IV)along);
4718                         PUSHs(sv_2mortal(sv));
4719                     }
4720                 }
4721                 else
4722 #endif
4723                 {
4724                     while (len-- > 0) {
4725 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4726                         I32 along;
4727 #endif
4728                         COPY32(s, &along);
4729 #if LONGSIZE > SIZE32
4730                         if (along > 2147483647)
4731                           along -= 4294967296;
4732 #endif
4733                         s += SIZE32;
4734                         sv = NEWSV(42, 0);
4735                         sv_setiv(sv, (IV)along);
4736                         PUSHs(sv_2mortal(sv));
4737                     }
4738                 }
4739             }
4740             break;
4741         case 'V':
4742         case 'N':
4743         case 'L':
4744 #if LONGSIZE == SIZE32
4745             along = (strend - s) / SIZE32;
4746 #else
4747             unatint = natint && datumtype == 'L';
4748             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4749 #endif
4750             if (len > along)
4751                 len = along;
4752             if (checksum) {
4753 #if LONGSIZE != SIZE32
4754                 if (unatint) {
4755                     unsigned long aulong;
4756                     while (len-- > 0) {
4757                         COPYNN(s, &aulong, sizeof(unsigned long));
4758                         s += sizeof(unsigned long);
4759                         if (checksum > 32)
4760                             cdouble += (NV)aulong;
4761                         else
4762                             culong += aulong;
4763                     }
4764                 }
4765                 else
4766 #endif
4767                 {
4768                     while (len-- > 0) {
4769                         COPY32(s, &aulong);
4770                         s += SIZE32;
4771 #ifdef HAS_NTOHL
4772                         if (datumtype == 'N')
4773                             aulong = PerlSock_ntohl(aulong);
4774 #endif
4775 #ifdef HAS_VTOHL
4776                         if (datumtype == 'V')
4777                             aulong = vtohl(aulong);
4778 #endif
4779                         if (checksum > 32)
4780                             cdouble += (NV)aulong;
4781                         else
4782                             culong += aulong;
4783                     }
4784                 }
4785             }
4786             else {
4787                 EXTEND(SP, len);
4788                 EXTEND_MORTAL(len);
4789 #if LONGSIZE != SIZE32
4790                 if (unatint) {
4791                     unsigned long aulong;
4792                     while (len-- > 0) {
4793                         COPYNN(s, &aulong, sizeof(unsigned long));
4794                         s += sizeof(unsigned long);
4795                         sv = NEWSV(43, 0);
4796                         sv_setuv(sv, (UV)aulong);
4797                         PUSHs(sv_2mortal(sv));
4798                     }
4799                 }
4800                 else
4801 #endif
4802                 {
4803                     while (len-- > 0) {
4804                         COPY32(s, &aulong);
4805                         s += SIZE32;
4806 #ifdef HAS_NTOHL
4807                         if (datumtype == 'N')
4808                             aulong = PerlSock_ntohl(aulong);
4809 #endif
4810 #ifdef HAS_VTOHL
4811                         if (datumtype == 'V')
4812                             aulong = vtohl(aulong);
4813 #endif
4814                         sv = NEWSV(43, 0);
4815                         sv_setuv(sv, (UV)aulong);
4816                         PUSHs(sv_2mortal(sv));
4817                     }
4818                 }
4819             }
4820             break;
4821         case 'p':
4822             along = (strend - s) / sizeof(char*);
4823             if (len > along)
4824                 len = along;
4825             EXTEND(SP, len);
4826             EXTEND_MORTAL(len);
4827             while (len-- > 0) {
4828                 if (sizeof(char*) > strend - s)
4829                     break;
4830                 else {
4831                     Copy(s, &aptr, 1, char*);
4832                     s += sizeof(char*);
4833                 }
4834                 sv = NEWSV(44, 0);
4835                 if (aptr)
4836                     sv_setpv(sv, aptr);
4837                 PUSHs(sv_2mortal(sv));
4838             }
4839             break;
4840         case 'w':
4841             EXTEND(SP, len);
4842             EXTEND_MORTAL(len);
4843             {
4844                 UV auv = 0;
4845                 U32 bytes = 0;
4846
4847                 while ((len > 0) && (s < strend)) {
4848                     auv = (auv << 7) | (*s & 0x7f);
4849                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4850                     if ((U8)(*s++) < 0x80) {
4851                         bytes = 0;
4852                         sv = NEWSV(40, 0);
4853                         sv_setuv(sv, auv);
4854                         PUSHs(sv_2mortal(sv));
4855                         len--;
4856                         auv = 0;
4857                     }
4858                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4859                         char *t;
4860                         STRLEN n_a;
4861
4862                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4863                         while (s < strend) {
4864                             sv = mul128(sv, *s & 0x7f);
4865                             if (!(*s++ & 0x80)) {
4866                                 bytes = 0;
4867                                 break;
4868                             }
4869                         }
4870                         t = SvPV(sv, n_a);
4871                         while (*t == '0')
4872                             t++;
4873                         sv_chop(sv, t);
4874                         PUSHs(sv_2mortal(sv));
4875                         len--;
4876                         auv = 0;
4877                     }
4878                 }
4879                 if ((s >= strend) && bytes)
4880                     DIE(aTHX_ "Unterminated compressed integer");
4881             }
4882             break;
4883         case 'P':
4884             EXTEND(SP, 1);
4885             if (sizeof(char*) > strend - s)
4886                 break;
4887             else {
4888                 Copy(s, &aptr, 1, char*);
4889                 s += sizeof(char*);
4890             }
4891             sv = NEWSV(44, 0);
4892             if (aptr)
4893                 sv_setpvn(sv, aptr, len);
4894             PUSHs(sv_2mortal(sv));
4895             break;
4896 #ifdef HAS_QUAD
4897         case 'q':
4898             along = (strend - s) / sizeof(Quad_t);
4899             if (len > along)
4900                 len = along;
4901             EXTEND(SP, len);
4902             EXTEND_MORTAL(len);
4903             while (len-- > 0) {
4904                 if (s + sizeof(Quad_t) > strend)
4905                     aquad = 0;
4906                 else {
4907                     Copy(s, &aquad, 1, Quad_t);
4908                     s += sizeof(Quad_t);
4909                 }
4910                 sv = NEWSV(42, 0);
4911                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4912                     sv_setiv(sv, (IV)aquad);
4913                 else
4914                     sv_setnv(sv, (NV)aquad);
4915                 PUSHs(sv_2mortal(sv));
4916             }
4917             break;
4918         case 'Q':
4919             along = (strend - s) / sizeof(Quad_t);
4920             if (len > along)
4921                 len = along;
4922             EXTEND(SP, len);
4923             EXTEND_MORTAL(len);
4924             while (len-- > 0) {
4925                 if (s + sizeof(Uquad_t) > strend)
4926                     auquad = 0;
4927                 else {
4928                     Copy(s, &auquad, 1, Uquad_t);
4929                     s += sizeof(Uquad_t);
4930                 }
4931                 sv = NEWSV(43, 0);
4932                 if (auquad <= UV_MAX)
4933                     sv_setuv(sv, (UV)auquad);
4934                 else
4935                     sv_setnv(sv, (NV)auquad);
4936                 PUSHs(sv_2mortal(sv));
4937             }
4938             break;
4939 #endif
4940         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4941         case 'f':
4942         case 'F':
4943             along = (strend - s) / sizeof(float);
4944             if (len > along)
4945                 len = along;
4946             if (checksum) {
4947                 while (len-- > 0) {
4948                     Copy(s, &afloat, 1, float);
4949                     s += sizeof(float);
4950                     cdouble += afloat;
4951                 }
4952             }
4953             else {
4954                 EXTEND(SP, len);
4955                 EXTEND_MORTAL(len);
4956                 while (len-- > 0) {
4957                     Copy(s, &afloat, 1, float);
4958                     s += sizeof(float);
4959                     sv = NEWSV(47, 0);
4960                     sv_setnv(sv, (NV)afloat);
4961                     PUSHs(sv_2mortal(sv));
4962                 }
4963             }
4964             break;
4965         case 'd':
4966         case 'D':
4967             along = (strend - s) / sizeof(double);
4968             if (len > along)
4969                 len = along;
4970             if (checksum) {
4971                 while (len-- > 0) {
4972                     Copy(s, &adouble, 1, double);
4973                     s += sizeof(double);
4974                     cdouble += adouble;
4975                 }
4976             }
4977             else {
4978                 EXTEND(SP, len);
4979                 EXTEND_MORTAL(len);
4980                 while (len-- > 0) {
4981                     Copy(s, &adouble, 1, double);
4982                     s += sizeof(double);
4983                     sv = NEWSV(48, 0);
4984                     sv_setnv(sv, (NV)adouble);
4985                     PUSHs(sv_2mortal(sv));
4986                 }
4987             }
4988             break;
4989         case 'u':
4990             /* MKS:
4991              * Initialise the decode mapping.  By using a table driven
4992              * algorithm, the code will be character-set independent
4993              * (and just as fast as doing character arithmetic)
4994              */
4995             if (PL_uudmap['M'] == 0) {
4996                 int i;
4997
4998                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4999                     PL_uudmap[(U8)PL_uuemap[i]] = i;
5000                 /*
5001                  * Because ' ' and '`' map to the same value,
5002                  * we need to decode them both the same.
5003                  */
5004                 PL_uudmap[' '] = 0;
5005             }
5006
5007             along = (strend - s) * 3 / 4;
5008             sv = NEWSV(42, along);
5009             if (along)
5010                 SvPOK_on(sv);
5011             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5012                 I32 a, b, c, d;
5013                 char hunk[4];
5014
5015                 hunk[3] = '\0';
5016                 len = PL_uudmap[*(U8*)s++] & 077;
5017                 while (len > 0) {
5018                     if (s < strend && ISUUCHAR(*s))
5019                         a = PL_uudmap[*(U8*)s++] & 077;
5020                     else
5021                         a = 0;
5022                     if (s < strend && ISUUCHAR(*s))
5023                         b = PL_uudmap[*(U8*)s++] & 077;
5024                     else
5025                         b = 0;
5026                     if (s < strend && ISUUCHAR(*s))
5027                         c = PL_uudmap[*(U8*)s++] & 077;
5028                     else
5029                         c = 0;
5030                     if (s < strend && ISUUCHAR(*s))
5031                         d = PL_uudmap[*(U8*)s++] & 077;
5032                     else
5033                         d = 0;
5034                     hunk[0] = (a << 2) | (b >> 4);
5035                     hunk[1] = (b << 4) | (c >> 2);
5036                     hunk[2] = (c << 6) | d;
5037                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5038                     len -= 3;
5039                 }
5040                 if (*s == '\n')
5041                     s++;
5042                 else if (s[1] == '\n')          /* possible checksum byte */
5043                     s += 2;
5044             }
5045             XPUSHs(sv_2mortal(sv));
5046             break;
5047         }
5048         if (checksum) {
5049             sv = NEWSV(42, 0);
5050             if (strchr("fFdD", datumtype) ||
5051               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5052                 NV trouble;
5053
5054                 adouble = 1.0;
5055                 while (checksum >= 16) {
5056                     checksum -= 16;
5057                     adouble *= 65536.0;
5058                 }
5059                 while (checksum >= 4) {
5060                     checksum -= 4;
5061                     adouble *= 16.0;
5062                 }
5063                 while (checksum--)
5064                     adouble *= 2.0;
5065                 along = (1 << checksum) - 1;
5066                 while (cdouble < 0.0)
5067                     cdouble += adouble;
5068                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5069                 sv_setnv(sv, cdouble);
5070             }
5071             else {
5072                 if (checksum < 32) {
5073                     aulong = (1 << checksum) - 1;
5074                     culong &= aulong;
5075                 }
5076                 sv_setuv(sv, (UV)culong);
5077             }
5078             XPUSHs(sv_2mortal(sv));
5079             checksum = 0;
5080         }
5081     }
5082     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5083         PUSHs(&PL_sv_undef);
5084     RETURN;
5085 }
5086
5087 STATIC void
5088 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5089 {
5090     char hunk[5];
5091
5092     *hunk = PL_uuemap[len];
5093     sv_catpvn(sv, hunk, 1);
5094     hunk[4] = '\0';
5095     while (len > 2) {
5096         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5097         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5098         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5099         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5100         sv_catpvn(sv, hunk, 4);
5101         s += 3;
5102         len -= 3;
5103     }
5104     if (len > 0) {
5105         char r = (len > 1 ? s[1] : '\0');
5106         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5107         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5108         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5109         hunk[3] = PL_uuemap[0];
5110         sv_catpvn(sv, hunk, 4);
5111     }
5112     sv_catpvn(sv, "\n", 1);
5113 }
5114
5115 STATIC SV *
5116 S_is_an_int(pTHX_ char *s, STRLEN l)
5117 {
5118   STRLEN         n_a;
5119   SV             *result = newSVpvn(s, l);
5120   char           *result_c = SvPV(result, n_a); /* convenience */
5121   char           *out = result_c;
5122   bool            skip = 1;
5123   bool            ignore = 0;
5124
5125   while (*s) {
5126     switch (*s) {
5127     case ' ':
5128       break;
5129     case '+':
5130       if (!skip) {
5131         SvREFCNT_dec(result);
5132         return (NULL);
5133       }
5134       break;
5135     case '0':
5136     case '1':
5137     case '2':
5138     case '3':
5139     case '4':
5140     case '5':
5141     case '6':
5142     case '7':
5143     case '8':
5144     case '9':
5145       skip = 0;
5146       if (!ignore) {
5147         *(out++) = *s;
5148       }
5149       break;
5150     case '.':
5151       ignore = 1;
5152       break;
5153     default:
5154       SvREFCNT_dec(result);
5155       return (NULL);
5156     }
5157     s++;
5158   }
5159   *(out++) = '\0';
5160   SvCUR_set(result, out - result_c);
5161   return (result);
5162 }
5163
5164 /* pnum must be '\0' terminated */
5165 STATIC int
5166 S_div128(pTHX_ SV *pnum, bool *done)
5167 {
5168   STRLEN          len;
5169   char           *s = SvPV(pnum, len);
5170   int             m = 0;
5171   int             r = 0;
5172   char           *t = s;
5173
5174   *done = 1;
5175   while (*t) {
5176     int             i;
5177
5178     i = m * 10 + (*t - '0');
5179     m = i & 0x7F;
5180     r = (i >> 7);               /* r < 10 */
5181     if (r) {
5182       *done = 0;
5183     }
5184     *(t++) = '0' + r;
5185   }
5186   *(t++) = '\0';
5187   SvCUR_set(pnum, (STRLEN) (t - s));
5188   return (m);
5189 }
5190
5191
5192 PP(pp_pack)
5193 {
5194     dSP; dMARK; dORIGMARK; dTARGET;
5195     register SV *cat = TARG;
5196     register I32 items;
5197     STRLEN fromlen;
5198     register char *pat = SvPVx(*++MARK, fromlen);
5199     char *patcopy;
5200     register char *patend = pat + fromlen;
5201     register I32 len;
5202     I32 datumtype;
5203     SV *fromstr;
5204     /*SUPPRESS 442*/
5205     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5206     static char *space10 = "          ";
5207
5208     /* These must not be in registers: */
5209     char achar;
5210     I16 ashort;
5211     int aint;
5212     unsigned int auint;
5213     I32 along;
5214     U32 aulong;
5215 #ifdef HAS_QUAD
5216     Quad_t aquad;
5217     Uquad_t auquad;
5218 #endif
5219     char *aptr;
5220     float afloat;
5221     double adouble;
5222     int commas = 0;
5223 #ifdef PERL_NATINT_PACK
5224     int natint;         /* native integer */
5225 #endif
5226
5227     items = SP - MARK;
5228     MARK++;
5229     sv_setpvn(cat, "", 0);
5230     patcopy = pat;
5231     while (pat < patend) {
5232         SV *lengthcode = Nullsv;
5233 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5234         datumtype = *pat++ & 0xFF;
5235 #ifdef PERL_NATINT_PACK
5236         natint = 0;
5237 #endif
5238         if (isSPACE(datumtype)) {
5239             patcopy++;
5240             continue;
5241         }
5242 #ifndef PACKED_IS_OCTETS
5243         if (datumtype == 'U' && pat == patcopy+1)
5244             SvUTF8_on(cat);
5245 #endif
5246         if (datumtype == '#') {
5247             while (pat < patend && *pat != '\n')
5248                 pat++;
5249             continue;
5250         }
5251         if (*pat == '!') {
5252             char *natstr = "sSiIlL";
5253
5254             if (strchr(natstr, datumtype)) {
5255 #ifdef PERL_NATINT_PACK
5256                 natint = 1;
5257 #endif
5258                 pat++;
5259             }
5260             else
5261                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5262         }
5263         if (*pat == '*') {
5264             len = strchr("@Xxu", datumtype) ? 0 : items;
5265             pat++;
5266         }
5267         else if (isDIGIT(*pat)) {
5268             len = *pat++ - '0';
5269             while (isDIGIT(*pat)) {
5270                 len = (len * 10) + (*pat++ - '0');
5271                 if (len < 0)
5272                     DIE(aTHX_ "Repeat count in pack overflows");
5273             }
5274         }
5275         else
5276             len = 1;
5277         if (*pat == '/') {
5278             ++pat;
5279             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5280                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5281             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5282                                                    ? *MARK : &PL_sv_no)
5283                                             + (*pat == 'Z' ? 1 : 0)));
5284         }
5285         switch(datumtype) {
5286         default:
5287             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5288         case ',': /* grandfather in commas but with a warning */
5289             if (commas++ == 0 && ckWARN(WARN_PACK))
5290                 Perl_warner(aTHX_ WARN_PACK,
5291                             "Invalid type in pack: '%c'", (int)datumtype);
5292             break;
5293         case '%':
5294             DIE(aTHX_ "%% may only be used in unpack");
5295         case '@':
5296             len -= SvCUR(cat);
5297             if (len > 0)
5298                 goto grow;
5299             len = -len;
5300             if (len > 0)
5301                 goto shrink;
5302             break;
5303         case 'X':
5304           shrink:
5305             if (SvCUR(cat) < len)
5306                 DIE(aTHX_ "X outside of string");
5307             SvCUR(cat) -= len;
5308             *SvEND(cat) = '\0';
5309             break;
5310         case 'x':
5311           grow:
5312             while (len >= 10) {
5313                 sv_catpvn(cat, null10, 10);
5314                 len -= 10;
5315             }
5316             sv_catpvn(cat, null10, len);
5317             break;
5318         case 'A':
5319         case 'Z':
5320         case 'a':
5321             fromstr = NEXTFROM;
5322             aptr = SvPV(fromstr, fromlen);
5323             if (pat[-1] == '*') {
5324                 len = fromlen;
5325                 if (datumtype == 'Z')
5326                     ++len;
5327             }
5328             if (fromlen >= len) {
5329                 sv_catpvn(cat, aptr, len);
5330                 if (datumtype == 'Z')
5331                     *(SvEND(cat)-1) = '\0';
5332             }
5333             else {
5334                 sv_catpvn(cat, aptr, fromlen);
5335                 len -= fromlen;
5336                 if (datumtype == 'A') {
5337                     while (len >= 10) {
5338                         sv_catpvn(cat, space10, 10);
5339                         len -= 10;
5340                     }
5341                     sv_catpvn(cat, space10, len);
5342                 }
5343                 else {
5344                     while (len >= 10) {
5345                         sv_catpvn(cat, null10, 10);
5346                         len -= 10;
5347                     }
5348                     sv_catpvn(cat, null10, len);
5349                 }
5350             }
5351             break;
5352         case 'B':
5353         case 'b':
5354             {
5355                 register char *str;
5356                 I32 saveitems;
5357
5358                 fromstr = NEXTFROM;
5359                 saveitems = items;
5360                 str = SvPV(fromstr, fromlen);
5361                 if (pat[-1] == '*')
5362                     len = fromlen;
5363                 aint = SvCUR(cat);
5364                 SvCUR(cat) += (len+7)/8;
5365                 SvGROW(cat, SvCUR(cat) + 1);
5366                 aptr = SvPVX(cat) + aint;
5367                 if (len > fromlen)
5368                     len = fromlen;
5369                 aint = len;
5370                 items = 0;
5371                 if (datumtype == 'B') {
5372                     for (len = 0; len++ < aint;) {
5373                         items |= *str++ & 1;
5374                         if (len & 7)
5375                             items <<= 1;
5376                         else {
5377                             *aptr++ = items & 0xff;
5378                             items = 0;
5379                         }
5380                     }
5381                 }
5382                 else {
5383                     for (len = 0; len++ < aint;) {
5384                         if (*str++ & 1)
5385                             items |= 128;
5386                         if (len & 7)
5387                             items >>= 1;
5388                         else {
5389                             *aptr++ = items & 0xff;
5390                             items = 0;
5391                         }
5392                     }
5393                 }
5394                 if (aint & 7) {
5395                     if (datumtype == 'B')
5396                         items <<= 7 - (aint & 7);
5397                     else
5398                         items >>= 7 - (aint & 7);
5399                     *aptr++ = items & 0xff;
5400                 }
5401                 str = SvPVX(cat) + SvCUR(cat);
5402                 while (aptr <= str)
5403                     *aptr++ = '\0';
5404
5405                 items = saveitems;
5406             }
5407             break;
5408         case 'H':
5409         case 'h':
5410             {
5411                 register char *str;
5412                 I32 saveitems;
5413
5414                 fromstr = NEXTFROM;
5415                 saveitems = items;
5416                 str = SvPV(fromstr, fromlen);
5417                 if (pat[-1] == '*')
5418                     len = fromlen;
5419                 aint = SvCUR(cat);
5420                 SvCUR(cat) += (len+1)/2;
5421                 SvGROW(cat, SvCUR(cat) + 1);
5422                 aptr = SvPVX(cat) + aint;
5423                 if (len > fromlen)
5424                     len = fromlen;
5425                 aint = len;
5426                 items = 0;
5427                 if (datumtype == 'H') {
5428                     for (len = 0; len++ < aint;) {
5429                         if (isALPHA(*str))
5430                             items |= ((*str++ & 15) + 9) & 15;
5431                         else
5432                             items |= *str++ & 15;
5433                         if (len & 1)
5434                             items <<= 4;
5435                         else {
5436                             *aptr++ = items & 0xff;
5437                             items = 0;
5438                         }
5439                     }
5440                 }
5441                 else {
5442                     for (len = 0; len++ < aint;) {
5443                         if (isALPHA(*str))
5444                             items |= (((*str++ & 15) + 9) & 15) << 4;
5445                         else
5446                             items |= (*str++ & 15) << 4;
5447                         if (len & 1)
5448                             items >>= 4;
5449                         else {
5450                             *aptr++ = items & 0xff;
5451                             items = 0;
5452                         }
5453                     }
5454                 }
5455                 if (aint & 1)
5456                     *aptr++ = items & 0xff;
5457                 str = SvPVX(cat) + SvCUR(cat);
5458                 while (aptr <= str)
5459                     *aptr++ = '\0';
5460
5461                 items = saveitems;
5462             }
5463             break;
5464         case 'C':
5465         case 'c':
5466             while (len-- > 0) {
5467                 fromstr = NEXTFROM;
5468                 switch (datumtype) {
5469                 case 'C':
5470                     aint = SvIV(fromstr);
5471                     if ((aint < 0 || aint > 255) &&
5472                         ckWARN(WARN_PACK))
5473                         Perl_warner(aTHX_ WARN_PACK,
5474                                     "Character in \"C\" format wrapped");
5475                     achar = aint & 255;
5476                     sv_catpvn(cat, &achar, sizeof(char));
5477                     break;
5478                 case 'c':
5479                     aint = SvIV(fromstr);
5480                     if ((aint < -128 || aint > 127) &&
5481                         ckWARN(WARN_PACK))
5482                         Perl_warner(aTHX_ WARN_PACK,
5483                                     "Character in \"c\" format wrapped");
5484                     achar = aint & 255;
5485                     sv_catpvn(cat, &achar, sizeof(char));
5486                     break;
5487                 }
5488             }
5489             break;
5490         case 'U':
5491             while (len-- > 0) {
5492                 fromstr = NEXTFROM;
5493                 auint = SvUV(fromstr);
5494                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5495                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5496                                - SvPVX(cat));
5497             }
5498             *SvEND(cat) = '\0';
5499             break;
5500         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
5501         case 'f':
5502         case 'F':
5503             while (len-- > 0) {
5504                 fromstr = NEXTFROM;
5505                 afloat = (float)SvNV(fromstr);
5506                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5507             }
5508             break;
5509         case 'd':
5510         case 'D':
5511             while (len-- > 0) {
5512                 fromstr = NEXTFROM;
5513                 adouble = (double)SvNV(fromstr);
5514                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5515             }
5516             break;
5517         case 'n':
5518             while (len-- > 0) {
5519                 fromstr = NEXTFROM;
5520                 ashort = (I16)SvIV(fromstr);
5521 #ifdef HAS_HTONS
5522                 ashort = PerlSock_htons(ashort);
5523 #endif
5524                 CAT16(cat, &ashort);
5525             }
5526             break;
5527         case 'v':
5528             while (len-- > 0) {
5529                 fromstr = NEXTFROM;
5530                 ashort = (I16)SvIV(fromstr);
5531 #ifdef HAS_HTOVS
5532                 ashort = htovs(ashort);
5533 #endif
5534                 CAT16(cat, &ashort);
5535             }
5536             break;
5537         case 'S':
5538 #if SHORTSIZE != SIZE16
5539             if (natint) {
5540                 unsigned short aushort;
5541
5542                 while (len-- > 0) {
5543                     fromstr = NEXTFROM;
5544                     aushort = SvUV(fromstr);
5545                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5546                 }
5547             }
5548             else
5549 #endif
5550             {
5551                 U16 aushort;
5552
5553                 while (len-- > 0) {
5554                     fromstr = NEXTFROM;
5555                     aushort = (U16)SvUV(fromstr);
5556                     CAT16(cat, &aushort);
5557                 }
5558
5559             }
5560             break;
5561         case 's':
5562 #if SHORTSIZE != SIZE16
5563             if (natint) {
5564                 short ashort;
5565
5566                 while (len-- > 0) {
5567                     fromstr = NEXTFROM;
5568                     ashort = SvIV(fromstr);
5569                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
5570                 }
5571             }
5572             else
5573 #endif
5574             {
5575                 while (len-- > 0) {
5576                     fromstr = NEXTFROM;
5577                     ashort = (I16)SvIV(fromstr);
5578                     CAT16(cat, &ashort);
5579                 }
5580             }
5581             break;
5582         case 'I':
5583             while (len-- > 0) {
5584                 fromstr = NEXTFROM;
5585                 auint = SvUV(fromstr);
5586                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5587             }
5588             break;
5589         case 'w':
5590             while (len-- > 0) {
5591                 fromstr = NEXTFROM;
5592                 adouble = Perl_floor(SvNV(fromstr));
5593
5594                 if (adouble < 0)
5595                     DIE(aTHX_ "Cannot compress negative numbers");
5596
5597                 if (
5598 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5599                     adouble <= 0xffffffff
5600 #else
5601 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
5602                     adouble <= UV_MAX_cxux
5603 #   else
5604                     adouble <= UV_MAX
5605 #   endif
5606 #endif
5607                     )
5608                 {
5609                     char   buf[1 + sizeof(UV)];
5610                     char  *in = buf + sizeof(buf);
5611                     UV     auv = U_V(adouble);
5612
5613                     do {
5614                         *--in = (auv & 0x7f) | 0x80;
5615                         auv >>= 7;
5616                     } while (auv);
5617                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5618                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5619                 }
5620                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
5621                     char           *from, *result, *in;
5622                     SV             *norm;
5623                     STRLEN          len;
5624                     bool            done;
5625
5626                     /* Copy string and check for compliance */
5627                     from = SvPV(fromstr, len);
5628                     if ((norm = is_an_int(from, len)) == NULL)
5629                         DIE(aTHX_ "can compress only unsigned integer");
5630
5631                     New('w', result, len, char);
5632                     in = result + len;
5633                     done = FALSE;
5634                     while (!done)
5635                         *--in = div128(norm, &done) | 0x80;
5636                     result[len - 1] &= 0x7F; /* clear continue bit */
5637                     sv_catpvn(cat, in, (result + len) - in);
5638                     Safefree(result);
5639                     SvREFCNT_dec(norm); /* free norm */
5640                 }
5641                 else if (SvNOKp(fromstr)) {
5642                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
5643                     char  *in = buf + sizeof(buf);
5644
5645                     do {
5646                         double next = floor(adouble / 128);
5647                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5648                         if (in <= buf)  /* this cannot happen ;-) */
5649                             DIE(aTHX_ "Cannot compress integer");
5650                         in--;
5651                         adouble = next;
5652                     } while (adouble > 0);
5653                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5654                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5655                 }
5656                 else
5657                     DIE(aTHX_ "Cannot compress non integer");
5658             }
5659             break;
5660         case 'i':
5661             while (len-- > 0) {
5662                 fromstr = NEXTFROM;
5663                 aint = SvIV(fromstr);
5664                 sv_catpvn(cat, (char*)&aint, sizeof(int));
5665             }
5666             break;
5667         case 'N':
5668             while (len-- > 0) {
5669                 fromstr = NEXTFROM;
5670                 aulong = SvUV(fromstr);
5671 #ifdef HAS_HTONL
5672                 aulong = PerlSock_htonl(aulong);
5673 #endif
5674                 CAT32(cat, &aulong);
5675             }
5676             break;
5677         case 'V':
5678             while (len-- > 0) {
5679                 fromstr = NEXTFROM;
5680                 aulong = SvUV(fromstr);
5681 #ifdef HAS_HTOVL
5682                 aulong = htovl(aulong);
5683 #endif
5684                 CAT32(cat, &aulong);
5685             }
5686             break;
5687         case 'L':
5688 #if LONGSIZE != SIZE32
5689             if (natint) {
5690                 unsigned long aulong;
5691
5692                 while (len-- > 0) {
5693                     fromstr = NEXTFROM;
5694                     aulong = SvUV(fromstr);
5695                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5696                 }
5697             }
5698             else
5699 #endif
5700             {
5701                 while (len-- > 0) {
5702                     fromstr = NEXTFROM;
5703                     aulong = SvUV(fromstr);
5704                     CAT32(cat, &aulong);
5705                 }
5706             }
5707             break;
5708         case 'l':
5709 #if LONGSIZE != SIZE32
5710             if (natint) {
5711                 long along;
5712
5713                 while (len-- > 0) {
5714                     fromstr = NEXTFROM;
5715                     along = SvIV(fromstr);
5716                     sv_catpvn(cat, (char *)&along, sizeof(long));
5717                 }
5718             }
5719             else
5720 #endif
5721             {
5722                 while (len-- > 0) {
5723                     fromstr = NEXTFROM;
5724                     along = SvIV(fromstr);
5725                     CAT32(cat, &along);
5726                 }
5727             }
5728             break;
5729 #ifdef HAS_QUAD
5730         case 'Q':
5731             while (len-- > 0) {
5732                 fromstr = NEXTFROM;
5733                 auquad = (Uquad_t)SvUV(fromstr);
5734                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5735             }
5736             break;
5737         case 'q':
5738             while (len-- > 0) {
5739                 fromstr = NEXTFROM;
5740                 aquad = (Quad_t)SvIV(fromstr);
5741                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5742             }
5743             break;
5744 #endif
5745         case 'P':
5746             len = 1;            /* assume SV is correct length */
5747             /* FALL THROUGH */
5748         case 'p':
5749             while (len-- > 0) {
5750                 fromstr = NEXTFROM;
5751                 if (fromstr == &PL_sv_undef)
5752                     aptr = NULL;
5753                 else {
5754                     STRLEN n_a;
5755                     /* XXX better yet, could spirit away the string to
5756                      * a safe spot and hang on to it until the result
5757                      * of pack() (and all copies of the result) are
5758                      * gone.
5759                      */
5760                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5761                                                 || (SvPADTMP(fromstr)
5762                                                     && !SvREADONLY(fromstr))))
5763                     {
5764                         Perl_warner(aTHX_ WARN_PACK,
5765                                 "Attempt to pack pointer to temporary value");
5766                     }
5767                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5768                         aptr = SvPV(fromstr,n_a);
5769                     else
5770                         aptr = SvPV_force(fromstr,n_a);
5771                 }
5772                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5773             }
5774             break;
5775         case 'u':
5776             fromstr = NEXTFROM;
5777             aptr = SvPV(fromstr, fromlen);
5778             SvGROW(cat, fromlen * 4 / 3);
5779             if (len <= 1)
5780                 len = 45;
5781             else
5782                 len = len / 3 * 3;
5783             while (fromlen > 0) {
5784                 I32 todo;
5785
5786                 if (fromlen > len)
5787                     todo = len;
5788                 else
5789                     todo = fromlen;
5790                 doencodes(cat, aptr, todo);
5791                 fromlen -= todo;
5792                 aptr += todo;
5793             }
5794             break;
5795         }
5796     }
5797     SvSETMAGIC(cat);
5798     SP = ORIGMARK;
5799     PUSHs(cat);
5800     RETURN;
5801 }
5802 #undef NEXTFROM
5803
5804
5805 PP(pp_split)
5806 {
5807     dSP; dTARG;
5808     AV *ary;
5809     register IV limit = POPi;                   /* note, negative is forever */
5810     SV *sv = POPs;
5811     STRLEN len;
5812     register char *s = SvPV(sv, len);
5813     bool do_utf8 = DO_UTF8(sv);
5814     char *strend = s + len;
5815     register PMOP *pm;
5816     register REGEXP *rx;
5817     register SV *dstr;
5818     register char *m;
5819     I32 iters = 0;
5820     STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5821     I32 maxiters = slen + 10;
5822     I32 i;
5823     char *orig;
5824     I32 origlimit = limit;
5825     I32 realarray = 0;
5826     I32 base;
5827     AV *oldstack = PL_curstack;
5828     I32 gimme = GIMME_V;
5829     I32 oldsave = PL_savestack_ix;
5830     I32 make_mortal = 1;
5831     MAGIC *mg = (MAGIC *) NULL;
5832
5833 #ifdef DEBUGGING
5834     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5835 #else
5836     pm = (PMOP*)POPs;
5837 #endif
5838     if (!pm || !s)
5839         DIE(aTHX_ "panic: pp_split");
5840     rx = pm->op_pmregexp;
5841
5842     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5843              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5844
5845     if (pm->op_pmreplroot) {
5846 #ifdef USE_ITHREADS
5847         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5848 #else
5849         ary = GvAVn((GV*)pm->op_pmreplroot);
5850 #endif
5851     }
5852     else if (gimme != G_ARRAY)
5853 #ifdef USE_THREADS
5854         ary = (AV*)PL_curpad[0];
5855 #else
5856         ary = GvAVn(PL_defgv);
5857 #endif /* USE_THREADS */
5858     else
5859         ary = Nullav;
5860     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5861         realarray = 1;
5862         PUTBACK;
5863         av_extend(ary,0);
5864         av_clear(ary);
5865         SPAGAIN;
5866         if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
5867             PUSHMARK(SP);
5868             XPUSHs(SvTIED_obj((SV*)ary, mg));
5869         }
5870         else {
5871             if (!AvREAL(ary)) {
5872                 AvREAL_on(ary);
5873                 AvREIFY_off(ary);
5874                 for (i = AvFILLp(ary); i >= 0; i--)
5875                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5876             }
5877             /* temporarily switch stacks */
5878             SWITCHSTACK(PL_curstack, ary);
5879             make_mortal = 0;
5880         }
5881     }
5882     base = SP - PL_stack_base;
5883     orig = s;
5884     if (pm->op_pmflags & PMf_SKIPWHITE) {
5885         if (pm->op_pmflags & PMf_LOCALE) {
5886             while (isSPACE_LC(*s))
5887                 s++;
5888         }
5889         else {
5890             while (isSPACE(*s))
5891                 s++;
5892         }
5893     }
5894     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5895         SAVEINT(PL_multiline);
5896         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5897     }
5898
5899     if (!limit)
5900         limit = maxiters + 2;
5901     if (pm->op_pmflags & PMf_WHITE) {
5902         while (--limit) {
5903             m = s;
5904             while (m < strend &&
5905                    !((pm->op_pmflags & PMf_LOCALE)
5906                      ? isSPACE_LC(*m) : isSPACE(*m)))
5907                 ++m;
5908             if (m >= strend)
5909                 break;
5910
5911             dstr = NEWSV(30, m-s);
5912             sv_setpvn(dstr, s, m-s);
5913             if (make_mortal)
5914                 sv_2mortal(dstr);
5915             if (do_utf8)
5916                 (void)SvUTF8_on(dstr);
5917             XPUSHs(dstr);
5918
5919             s = m + 1;
5920             while (s < strend &&
5921                    ((pm->op_pmflags & PMf_LOCALE)
5922                     ? isSPACE_LC(*s) : isSPACE(*s)))
5923                 ++s;
5924         }
5925     }
5926     else if (strEQ("^", rx->precomp)) {
5927         while (--limit) {
5928             /*SUPPRESS 530*/
5929             for (m = s; m < strend && *m != '\n'; m++) ;
5930             m++;
5931             if (m >= strend)
5932                 break;
5933             dstr = NEWSV(30, m-s);
5934             sv_setpvn(dstr, s, m-s);
5935             if (make_mortal)
5936                 sv_2mortal(dstr);
5937             if (do_utf8)
5938                 (void)SvUTF8_on(dstr);
5939             XPUSHs(dstr);
5940             s = m;
5941         }
5942     }
5943     else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5944              (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5945              && (rx->reganch & ROPT_CHECK_ALL)
5946              && !(rx->reganch & ROPT_ANCH)) {
5947         int tail = (rx->reganch & RE_INTUIT_TAIL);
5948         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5949
5950         len = rx->minlen;
5951         if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5952             STRLEN n_a;
5953             char c = *SvPV(csv, n_a);
5954             while (--limit) {
5955                 /*SUPPRESS 530*/
5956                 for (m = s; m < strend && *m != c; m++) ;
5957                 if (m >= strend)
5958                     break;
5959                 dstr = NEWSV(30, m-s);
5960                 sv_setpvn(dstr, s, m-s);
5961                 if (make_mortal)
5962                     sv_2mortal(dstr);
5963                 if (do_utf8)
5964                     (void)SvUTF8_on(dstr);
5965                 XPUSHs(dstr);
5966                 /* The rx->minlen is in characters but we want to step
5967                  * s ahead by bytes. */
5968                 if (do_utf8)
5969                     s = (char*)utf8_hop((U8*)m, len);
5970                 else
5971                     s = m + len; /* Fake \n at the end */
5972             }
5973         }
5974         else {
5975 #ifndef lint
5976             while (s < strend && --limit &&
5977               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5978                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5979 #endif
5980             {
5981                 dstr = NEWSV(31, m-s);
5982                 sv_setpvn(dstr, s, m-s);
5983                 if (make_mortal)
5984                     sv_2mortal(dstr);
5985                 if (do_utf8)
5986                     (void)SvUTF8_on(dstr);
5987                 XPUSHs(dstr);
5988                 /* The rx->minlen is in characters but we want to step
5989                  * s ahead by bytes. */
5990                 if (do_utf8)
5991                     s = (char*)utf8_hop((U8*)m, len);
5992                 else
5993                     s = m + len; /* Fake \n at the end */
5994             }
5995         }
5996     }
5997     else {
5998         maxiters += slen * rx->nparens;
5999         while (s < strend && --limit
6000 /*             && (!rx->check_substr
6001                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
6002                                                  0, NULL))))
6003 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
6004                               1 /* minend */, sv, NULL, 0))
6005         {
6006             TAINT_IF(RX_MATCH_TAINTED(rx));
6007             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
6008                 m = s;
6009                 s = orig;
6010                 orig = rx->subbeg;
6011                 s = orig + (m - s);
6012                 strend = s + (strend - m);
6013             }
6014             m = rx->startp[0] + orig;
6015             dstr = NEWSV(32, m-s);
6016             sv_setpvn(dstr, s, m-s);
6017             if (make_mortal)
6018                 sv_2mortal(dstr);
6019             if (do_utf8)
6020                 (void)SvUTF8_on(dstr);
6021             XPUSHs(dstr);
6022             if (rx->nparens) {
6023                 for (i = 1; i <= rx->nparens; i++) {
6024                     s = rx->startp[i] + orig;
6025                     m = rx->endp[i] + orig;
6026                     if (m && s) {
6027                         dstr = NEWSV(33, m-s);
6028                         sv_setpvn(dstr, s, m-s);
6029                     }
6030                     else
6031                         dstr = NEWSV(33, 0);
6032                     if (make_mortal)
6033                         sv_2mortal(dstr);
6034                     if (do_utf8)
6035                         (void)SvUTF8_on(dstr);
6036                     XPUSHs(dstr);
6037                 }
6038             }
6039             s = rx->endp[0] + orig;
6040         }
6041     }
6042
6043     LEAVE_SCOPE(oldsave);
6044     iters = (SP - PL_stack_base) - base;
6045     if (iters > maxiters)
6046         DIE(aTHX_ "Split loop");
6047
6048     /* keep field after final delim? */
6049     if (s < strend || (iters && origlimit)) {
6050         STRLEN l = strend - s;
6051         dstr = NEWSV(34, l);
6052         sv_setpvn(dstr, s, l);
6053         if (make_mortal)
6054             sv_2mortal(dstr);
6055         if (do_utf8)
6056             (void)SvUTF8_on(dstr);
6057         XPUSHs(dstr);
6058         iters++;
6059     }
6060     else if (!origlimit) {
6061         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6062             iters--, SP--;
6063     }
6064
6065     if (realarray) {
6066         if (!mg) {
6067             SWITCHSTACK(ary, oldstack);
6068             if (SvSMAGICAL(ary)) {
6069                 PUTBACK;
6070                 mg_set((SV*)ary);
6071                 SPAGAIN;
6072             }
6073             if (gimme == G_ARRAY) {
6074                 EXTEND(SP, iters);
6075                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6076                 SP += iters;
6077                 RETURN;
6078             }
6079         }
6080         else {
6081             PUTBACK;
6082             ENTER;
6083             call_method("PUSH",G_SCALAR|G_DISCARD);
6084             LEAVE;
6085             SPAGAIN;
6086             if (gimme == G_ARRAY) {
6087                 /* EXTEND should not be needed - we just popped them */
6088                 EXTEND(SP, iters);
6089                 for (i=0; i < iters; i++) {
6090                     SV **svp = av_fetch(ary, i, FALSE);
6091                     PUSHs((svp) ? *svp : &PL_sv_undef);
6092                 }
6093                 RETURN;
6094             }
6095         }
6096     }
6097     else {
6098         if (gimme == G_ARRAY)
6099             RETURN;
6100     }
6101     if (iters || !pm->op_pmreplroot) {
6102         GETTARGET;
6103         PUSHi(iters);
6104         RETURN;
6105     }
6106     RETPUSHUNDEF;
6107 }
6108
6109 #ifdef USE_THREADS
6110 void
6111 Perl_unlock_condpair(pTHX_ void *svv)
6112 {
6113     MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
6114
6115     if (!mg)
6116         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6117     MUTEX_LOCK(MgMUTEXP(mg));
6118     if (MgOWNER(mg) != thr)
6119         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6120     MgOWNER(mg) = 0;
6121     COND_SIGNAL(MgOWNERCONDP(mg));
6122     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6123                           PTR2UV(thr), PTR2UV(svv));)
6124     MUTEX_UNLOCK(MgMUTEXP(mg));
6125 }
6126 #endif /* USE_THREADS */
6127
6128 PP(pp_lock)
6129 {
6130     dSP;
6131     dTOPss;
6132     SV *retsv = sv;
6133 #ifdef USE_THREADS
6134     sv_lock(sv);
6135 #endif /* USE_THREADS */
6136     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6137         || SvTYPE(retsv) == SVt_PVCV) {
6138         retsv = refto(retsv);
6139     }
6140     SETs(retsv);
6141     RETURN;
6142 }
6143
6144 PP(pp_threadsv)
6145 {
6146 #ifdef USE_THREADS
6147     dSP;
6148     EXTEND(SP, 1);
6149     if (PL_op->op_private & OPpLVAL_INTRO)
6150         PUSHs(*save_threadsv(PL_op->op_targ));
6151     else
6152         PUSHs(THREADSV(PL_op->op_targ));
6153     RETURN;
6154 #else
6155     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6156 #endif /* USE_THREADS */
6157 }