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