pp.c

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