pp.c

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