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     dTHR;
1796 #ifndef PERL_NO_DEV_RANDOM
1797     int fd;
1798 #endif
1799     U32 u;
1800 #ifdef VMS
1801 #  include <starlet.h>
1802     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1803      * in 100-ns units, typically incremented ever 10 ms.        */
1804     unsigned int when[2];
1805 #else
1806 #  ifdef HAS_GETTIMEOFDAY
1807     struct timeval when;
1808 #  else
1809     Time_t when;
1810 #  endif
1811 #endif
1812
1813 /* This test is an escape hatch, this symbol isn't set by Configure. */
1814 #ifndef PERL_NO_DEV_RANDOM
1815 #ifndef PERL_RANDOM_DEVICE
1816    /* /dev/random isn't used by default because reads from it will block
1817     * if there isn't enough entropy available.  You can compile with
1818     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1819     * is enough real entropy to fill the seed. */
1820 #  define PERL_RANDOM_DEVICE "/dev/urandom"
1821 #endif
1822     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1823     if (fd != -1) {
1824         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1825             u = 0;
1826         PerlLIO_close(fd);
1827         if (u)
1828             return u;
1829     }
1830 #endif
1831
1832 #ifdef VMS
1833     _ckvmssts(sys$gettim(when));
1834     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1835 #else
1836 #  ifdef HAS_GETTIMEOFDAY
1837     gettimeofday(&when,(struct timezone *) 0);
1838     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1839 #  else
1840     (void)time(&when);
1841     u = (U32)SEED_C1 * when;
1842 #  endif
1843 #endif
1844     u += SEED_C3 * (U32)PerlProc_getpid();
1845     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1846 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1847     u += SEED_C5 * (U32)PTR2UV(&when);
1848 #endif
1849     return u;
1850 }
1851
1852 PP(pp_exp)
1853 {
1854     djSP; dTARGET; tryAMAGICun(exp);
1855     {
1856       NV value;
1857       value = POPn;
1858       value = Perl_exp(value);
1859       XPUSHn(value);
1860       RETURN;
1861     }
1862 }
1863
1864 PP(pp_log)
1865 {
1866     djSP; dTARGET; tryAMAGICun(log);
1867     {
1868       NV value;
1869       value = POPn;
1870       if (value <= 0.0) {
1871         SET_NUMERIC_STANDARD();
1872         DIE(aTHX_ "Can't take log of %g", value);
1873       }
1874       value = Perl_log(value);
1875       XPUSHn(value);
1876       RETURN;
1877     }
1878 }
1879
1880 PP(pp_sqrt)
1881 {
1882     djSP; dTARGET; tryAMAGICun(sqrt);
1883     {
1884       NV value;
1885       value = POPn;
1886       if (value < 0.0) {
1887         SET_NUMERIC_STANDARD();
1888         DIE(aTHX_ "Can't take sqrt of %g", value);
1889       }
1890       value = Perl_sqrt(value);
1891       XPUSHn(value);
1892       RETURN;
1893     }
1894 }
1895
1896 PP(pp_int)
1897 {
1898     djSP; dTARGET;
1899     {
1900       NV value = TOPn;
1901       IV iv;
1902
1903       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1904         iv = SvIVX(TOPs);
1905         SETi(iv);
1906       }
1907       else {
1908           if (value >= 0.0) {
1909 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1910               (void)Perl_modf(value, &value);
1911 #else
1912               double tmp = (double)value;
1913               (void)Perl_modf(tmp, &tmp);
1914               value = (NV)tmp;
1915 #endif
1916           }
1917         else {
1918 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1919             (void)Perl_modf(-value, &value);
1920             value = -value;
1921 #else
1922             double tmp = (double)value;
1923             (void)Perl_modf(-tmp, &tmp);
1924             value = -(NV)tmp;
1925 #endif
1926         }
1927         iv = I_V(value);
1928         if (iv == value)
1929           SETi(iv);
1930         else
1931           SETn(value);
1932       }
1933     }
1934     RETURN;
1935 }
1936
1937 PP(pp_abs)
1938 {
1939     djSP; dTARGET; tryAMAGICun(abs);
1940     {
1941       NV value = TOPn;
1942       IV iv;
1943
1944       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1945           (iv = SvIVX(TOPs)) != IV_MIN) {
1946         if (iv < 0)
1947           iv = -iv;
1948         SETi(iv);
1949       }
1950       else {
1951         if (value < 0.0)
1952             value = -value;
1953         SETn(value);
1954       }
1955     }
1956     RETURN;
1957 }
1958
1959 PP(pp_hex)
1960 {
1961     djSP; dTARGET;
1962     char *tmps;
1963     STRLEN argtype;
1964     STRLEN n_a;
1965
1966     tmps = POPpx;
1967     argtype = 1;                /* allow underscores */
1968     XPUSHn(scan_hex(tmps, 99, &argtype));
1969     RETURN;
1970 }
1971
1972 PP(pp_oct)
1973 {
1974     djSP; dTARGET;
1975     NV value;
1976     STRLEN argtype;
1977     char *tmps;
1978     STRLEN n_a;
1979
1980     tmps = POPpx;
1981     while (*tmps && isSPACE(*tmps))
1982         tmps++;
1983     if (*tmps == '0')
1984         tmps++;
1985     argtype = 1;                /* allow underscores */
1986     if (*tmps == 'x')
1987         value = scan_hex(++tmps, 99, &argtype);
1988     else if (*tmps == 'b')
1989         value = scan_bin(++tmps, 99, &argtype);
1990     else
1991         value = scan_oct(tmps, 99, &argtype);
1992     XPUSHn(value);
1993     RETURN;
1994 }
1995
1996 /* String stuff. */
1997
1998 PP(pp_length)
1999 {
2000     djSP; dTARGET;
2001     SV *sv = TOPs;
2002
2003     if (DO_UTF8(sv))
2004         SETi(sv_len_utf8(sv));
2005     else
2006         SETi(sv_len(sv));
2007     RETURN;
2008 }
2009
2010 PP(pp_substr)
2011 {
2012     djSP; dTARGET;
2013     SV *sv;
2014     I32 len;
2015     STRLEN curlen;
2016     STRLEN utfcurlen;
2017     I32 pos;
2018     I32 rem;
2019     I32 fail;
2020     I32 lvalue = PL_op->op_flags & OPf_MOD;
2021     char *tmps;
2022     I32 arybase = PL_curcop->cop_arybase;
2023     char *repl = 0;
2024     STRLEN repl_len;
2025
2026     SvTAINTED_off(TARG);                        /* decontaminate */
2027     SvUTF8_off(TARG);                           /* decontaminate */
2028     if (MAXARG > 2) {
2029         if (MAXARG > 3) {
2030             sv = POPs;
2031             repl = SvPV(sv, repl_len);
2032         }
2033         len = POPi;
2034     }
2035     pos = POPi;
2036     sv = POPs;
2037     PUTBACK;
2038     tmps = SvPV(sv, curlen);
2039     if (DO_UTF8(sv)) {
2040         utfcurlen = sv_len_utf8(sv);
2041         if (utfcurlen == curlen)
2042             utfcurlen = 0;
2043         else
2044             curlen = utfcurlen;
2045     }
2046     else
2047         utfcurlen = 0;
2048
2049     if (pos >= arybase) {
2050         pos -= arybase;
2051         rem = curlen-pos;
2052         fail = rem;
2053         if (MAXARG > 2) {
2054             if (len < 0) {
2055                 rem += len;
2056                 if (rem < 0)
2057                     rem = 0;
2058             }
2059             else if (rem > len)
2060                      rem = len;
2061         }
2062     }
2063     else {
2064         pos += curlen;
2065         if (MAXARG < 3)
2066             rem = curlen;
2067         else if (len >= 0) {
2068             rem = pos+len;
2069             if (rem > (I32)curlen)
2070                 rem = curlen;
2071         }
2072         else {
2073             rem = curlen+len;
2074             if (rem < pos)
2075                 rem = pos;
2076         }
2077         if (pos < 0)
2078             pos = 0;
2079         fail = rem;
2080         rem -= pos;
2081     }
2082     if (fail < 0) {
2083         if (lvalue || repl)
2084             Perl_croak(aTHX_ "substr outside of string");
2085         if (ckWARN(WARN_SUBSTR))
2086             Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2087         RETPUSHUNDEF;
2088     }
2089     else {
2090         if (utfcurlen)
2091             sv_pos_u2b(sv, &pos, &rem);
2092         tmps += pos;
2093         sv_setpvn(TARG, tmps, rem);
2094         if (utfcurlen)
2095             SvUTF8_on(TARG);
2096         if (repl)
2097             sv_insert(sv, pos, rem, repl, repl_len);
2098         else if (lvalue) {              /* it's an lvalue! */
2099             if (!SvGMAGICAL(sv)) {
2100                 if (SvROK(sv)) {
2101                     STRLEN n_a;
2102                     SvPV_force(sv,n_a);
2103                     if (ckWARN(WARN_SUBSTR))
2104                         Perl_warner(aTHX_ WARN_SUBSTR,
2105                                 "Attempt to use reference as lvalue in substr");
2106                 }
2107                 if (SvOK(sv))           /* is it defined ? */
2108                     (void)SvPOK_only_UTF8(sv);
2109                 else
2110                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2111             }
2112
2113             if (SvTYPE(TARG) < SVt_PVLV) {
2114                 sv_upgrade(TARG, SVt_PVLV);
2115                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2116             }
2117
2118             LvTYPE(TARG) = 'x';
2119             if (LvTARG(TARG) != sv) {
2120                 if (LvTARG(TARG))
2121                     SvREFCNT_dec(LvTARG(TARG));
2122                 LvTARG(TARG) = SvREFCNT_inc(sv);
2123             }
2124             LvTARGOFF(TARG) = pos;
2125             LvTARGLEN(TARG) = rem;
2126         }
2127     }
2128     SPAGAIN;
2129     PUSHs(TARG);                /* avoid SvSETMAGIC here */
2130     RETURN;
2131 }
2132
2133 PP(pp_vec)
2134 {
2135     djSP; dTARGET;
2136     register IV size   = POPi;
2137     register IV offset = POPi;
2138     register SV *src = POPs;
2139     I32 lvalue = PL_op->op_flags & OPf_MOD;
2140
2141     SvTAINTED_off(TARG);                /* decontaminate */
2142     if (lvalue) {                       /* it's an lvalue! */
2143         if (SvTYPE(TARG) < SVt_PVLV) {
2144             sv_upgrade(TARG, SVt_PVLV);
2145             sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2146         }
2147         LvTYPE(TARG) = 'v';
2148         if (LvTARG(TARG) != src) {
2149             if (LvTARG(TARG))
2150                 SvREFCNT_dec(LvTARG(TARG));
2151             LvTARG(TARG) = SvREFCNT_inc(src);
2152         }
2153         LvTARGOFF(TARG) = offset;
2154         LvTARGLEN(TARG) = size;
2155     }
2156
2157     sv_setuv(TARG, do_vecget(src, offset, size));
2158     PUSHs(TARG);
2159     RETURN;
2160 }
2161
2162 PP(pp_index)
2163 {
2164     djSP; dTARGET;
2165     SV *big;
2166     SV *little;
2167     I32 offset;
2168     I32 retval;
2169     char *tmps;
2170     char *tmps2;
2171     STRLEN biglen;
2172     I32 arybase = PL_curcop->cop_arybase;
2173
2174     if (MAXARG < 3)
2175         offset = 0;
2176     else
2177         offset = POPi - arybase;
2178     little = POPs;
2179     big = POPs;
2180     tmps = SvPV(big, biglen);
2181     if (offset > 0 && DO_UTF8(big))
2182         sv_pos_u2b(big, &offset, 0);
2183     if (offset < 0)
2184         offset = 0;
2185     else if (offset > biglen)
2186         offset = biglen;
2187     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2188       (unsigned char*)tmps + biglen, little, 0)))
2189         retval = -1;
2190     else
2191         retval = tmps2 - tmps;
2192     if (retval > 0 && DO_UTF8(big))
2193         sv_pos_b2u(big, &retval);
2194     PUSHi(retval + arybase);
2195     RETURN;
2196 }
2197
2198 PP(pp_rindex)
2199 {
2200     djSP; dTARGET;
2201     SV *big;
2202     SV *little;
2203     STRLEN blen;
2204     STRLEN llen;
2205     I32 offset;
2206     I32 retval;
2207     char *tmps;
2208     char *tmps2;
2209     I32 arybase = PL_curcop->cop_arybase;
2210
2211     if (MAXARG >= 3)
2212         offset = POPi;
2213     little = POPs;
2214     big = POPs;
2215     tmps2 = SvPV(little, llen);
2216     tmps = SvPV(big, blen);
2217     if (MAXARG < 3)
2218         offset = blen;
2219     else {
2220         if (offset > 0 && DO_UTF8(big))
2221             sv_pos_u2b(big, &offset, 0);
2222         offset = offset - arybase + llen;
2223     }
2224     if (offset < 0)
2225         offset = 0;
2226     else if (offset > blen)
2227         offset = blen;
2228     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2229                           tmps2, tmps2 + llen)))
2230         retval = -1;
2231     else
2232         retval = tmps2 - tmps;
2233     if (retval > 0 && DO_UTF8(big))
2234         sv_pos_b2u(big, &retval);
2235     PUSHi(retval + arybase);
2236     RETURN;
2237 }
2238
2239 PP(pp_sprintf)
2240 {
2241     djSP; dMARK; dORIGMARK; dTARGET;
2242     do_sprintf(TARG, SP-MARK, MARK+1);
2243     TAINT_IF(SvTAINTED(TARG));
2244     SP = ORIGMARK;
2245     PUSHTARG;
2246     RETURN;
2247 }
2248
2249 PP(pp_ord)
2250 {
2251     djSP; dTARGET;
2252     UV value;
2253     SV *tmpsv = POPs;
2254     STRLEN len;
2255     U8 *tmps = (U8*)SvPVx(tmpsv, len);
2256     STRLEN retlen;
2257
2258     if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2259         value = utf8_to_uv(tmps, len, &retlen, 0);
2260     else
2261         value = (UV)(*tmps & 255);
2262     XPUSHu(value);
2263     RETURN;
2264 }
2265
2266 PP(pp_chr)
2267 {
2268     djSP; dTARGET;
2269     char *tmps;
2270     UV value = POPu;
2271
2272     (void)SvUPGRADE(TARG,SVt_PV);
2273
2274     if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2275         SvGROW(TARG, UTF8_MAXLEN+1);
2276         tmps = SvPVX(TARG);
2277         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2278         SvCUR_set(TARG, tmps - SvPVX(TARG));
2279         *tmps = '\0';
2280         (void)SvPOK_only(TARG);
2281         SvUTF8_on(TARG);
2282         XPUSHs(TARG);
2283         RETURN;
2284     }
2285
2286     SvGROW(TARG,2);
2287     SvCUR_set(TARG, 1);
2288     tmps = SvPVX(TARG);
2289     *tmps++ = value;
2290     *tmps = '\0';
2291     (void)SvPOK_only(TARG);
2292     XPUSHs(TARG);
2293     RETURN;
2294 }
2295
2296 PP(pp_crypt)
2297 {
2298     djSP; dTARGET; dPOPTOPssrl;
2299     STRLEN n_a;
2300 #ifdef HAS_CRYPT
2301     char *tmps = SvPV(left, n_a);
2302 #ifdef FCRYPT
2303     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2304 #else
2305     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2306 #endif
2307 #else
2308     DIE(aTHX_
2309       "The crypt() function is unimplemented due to excessive paranoia.");
2310 #endif
2311     SETs(TARG);
2312     RETURN;
2313 }
2314
2315 PP(pp_ucfirst)
2316 {
2317     djSP;
2318     SV *sv = TOPs;
2319     register U8 *s;
2320     STRLEN slen;
2321
2322     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2323         STRLEN ulen;
2324         U8 tmpbuf[UTF8_MAXLEN+1];
2325         U8 *tend;
2326         UV uv = utf8_to_uv(s, slen, &ulen, 0);
2327
2328         if (PL_op->op_private & OPpLOCALE) {
2329             TAINT;
2330             SvTAINTED_on(sv);
2331             uv = toTITLE_LC_uni(uv);
2332         }
2333         else
2334             uv = toTITLE_utf8(s);
2335
2336         tend = uv_to_utf8(tmpbuf, uv);
2337
2338         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2339             dTARGET;
2340             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2341             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2342             SvUTF8_on(TARG);
2343             SETs(TARG);
2344         }
2345         else {
2346             s = (U8*)SvPV_force(sv, slen);
2347             Copy(tmpbuf, s, ulen, U8);
2348         }
2349     }
2350     else {
2351         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2352             dTARGET;
2353             SvUTF8_off(TARG);                           /* decontaminate */
2354             sv_setsv(TARG, sv);
2355             sv = TARG;
2356             SETs(sv);
2357         }
2358         s = (U8*)SvPV_force(sv, slen);
2359         if (*s) {
2360             if (PL_op->op_private & OPpLOCALE) {
2361                 TAINT;
2362                 SvTAINTED_on(sv);
2363                 *s = toUPPER_LC(*s);
2364             }
2365             else
2366                 *s = toUPPER(*s);
2367         }
2368     }
2369     if (SvSMAGICAL(sv))
2370         mg_set(sv);
2371     RETURN;
2372 }
2373
2374 PP(pp_lcfirst)
2375 {
2376     djSP;
2377     SV *sv = TOPs;
2378     register U8 *s;
2379     STRLEN slen;
2380
2381     if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2382         STRLEN ulen;
2383         U8 tmpbuf[UTF8_MAXLEN+1];
2384         U8 *tend;
2385         UV uv = utf8_to_uv(s, slen, &ulen, 0);
2386
2387         if (PL_op->op_private & OPpLOCALE) {
2388             TAINT;
2389             SvTAINTED_on(sv);
2390             uv = toLOWER_LC_uni(uv);
2391         }
2392         else
2393             uv = toLOWER_utf8(s);
2394
2395         tend = uv_to_utf8(tmpbuf, uv);
2396
2397         if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2398             dTARGET;
2399             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2400             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2401             SvUTF8_on(TARG);
2402             SETs(TARG);
2403         }
2404         else {
2405             s = (U8*)SvPV_force(sv, slen);
2406             Copy(tmpbuf, s, ulen, U8);
2407         }
2408     }
2409     else {
2410         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2411             dTARGET;
2412             SvUTF8_off(TARG);                           /* decontaminate */
2413             sv_setsv(TARG, sv);
2414             sv = TARG;
2415             SETs(sv);
2416         }
2417         s = (U8*)SvPV_force(sv, slen);
2418         if (*s) {
2419             if (PL_op->op_private & OPpLOCALE) {
2420                 TAINT;
2421                 SvTAINTED_on(sv);
2422                 *s = toLOWER_LC(*s);
2423             }
2424             else
2425                 *s = toLOWER(*s);
2426         }
2427     }
2428     if (SvSMAGICAL(sv))
2429         mg_set(sv);
2430     RETURN;
2431 }
2432
2433 PP(pp_uc)
2434 {
2435     djSP;
2436     SV *sv = TOPs;
2437     register U8 *s;
2438     STRLEN len;
2439
2440     if (DO_UTF8(sv)) {
2441         dTARGET;
2442         STRLEN ulen;
2443         register U8 *d;
2444         U8 *send;
2445
2446         s = (U8*)SvPV(sv,len);
2447         if (!len) {
2448             SvUTF8_off(TARG);                           /* decontaminate */
2449             sv_setpvn(TARG, "", 0);
2450             SETs(TARG);
2451         }
2452         else {
2453             (void)SvUPGRADE(TARG, SVt_PV);
2454             SvGROW(TARG, (len * 2) + 1);
2455             (void)SvPOK_only(TARG);
2456             d = (U8*)SvPVX(TARG);
2457             send = s + len;
2458             if (PL_op->op_private & OPpLOCALE) {
2459                 TAINT;
2460                 SvTAINTED_on(TARG);
2461                 while (s < send) {
2462                     d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2463                     s += ulen;
2464                 }
2465             }
2466             else {
2467                 while (s < send) {
2468                     d = uv_to_utf8(d, toUPPER_utf8( s ));
2469                     s += UTF8SKIP(s);
2470                 }
2471             }
2472             *d = '\0';
2473             SvUTF8_on(TARG);
2474             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2475             SETs(TARG);
2476         }
2477     }
2478     else {
2479         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2480             dTARGET;
2481             SvUTF8_off(TARG);                           /* decontaminate */
2482             sv_setsv(TARG, sv);
2483             sv = TARG;
2484             SETs(sv);
2485         }
2486         s = (U8*)SvPV_force(sv, len);
2487         if (len) {
2488             register U8 *send = s + len;
2489
2490             if (PL_op->op_private & OPpLOCALE) {
2491                 TAINT;
2492                 SvTAINTED_on(sv);
2493                 for (; s < send; s++)
2494                     *s = toUPPER_LC(*s);
2495             }
2496             else {
2497                 for (; s < send; s++)
2498                     *s = toUPPER(*s);
2499             }
2500         }
2501     }
2502     if (SvSMAGICAL(sv))
2503         mg_set(sv);
2504     RETURN;
2505 }
2506
2507 PP(pp_lc)
2508 {
2509     djSP;
2510     SV *sv = TOPs;
2511     register U8 *s;
2512     STRLEN len;
2513
2514     if (DO_UTF8(sv)) {
2515         dTARGET;
2516         STRLEN ulen;
2517         register U8 *d;
2518         U8 *send;
2519
2520         s = (U8*)SvPV(sv,len);
2521         if (!len) {
2522             SvUTF8_off(TARG);                           /* decontaminate */
2523             sv_setpvn(TARG, "", 0);
2524             SETs(TARG);
2525         }
2526         else {
2527             (void)SvUPGRADE(TARG, SVt_PV);
2528             SvGROW(TARG, (len * 2) + 1);
2529             (void)SvPOK_only(TARG);
2530             d = (U8*)SvPVX(TARG);
2531             send = s + len;
2532             if (PL_op->op_private & OPpLOCALE) {
2533                 TAINT;
2534                 SvTAINTED_on(TARG);
2535                 while (s < send) {
2536                     d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2537                     s += ulen;
2538                 }
2539             }
2540             else {
2541                 while (s < send) {
2542                     d = uv_to_utf8(d, toLOWER_utf8(s));
2543                     s += UTF8SKIP(s);
2544                 }
2545             }
2546             *d = '\0';
2547             SvUTF8_on(TARG);
2548             SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2549             SETs(TARG);
2550         }
2551     }
2552     else {
2553         if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2554             dTARGET;
2555             SvUTF8_off(TARG);                           /* decontaminate */
2556             sv_setsv(TARG, sv);
2557             sv = TARG;
2558             SETs(sv);
2559         }
2560
2561         s = (U8*)SvPV_force(sv, len);
2562         if (len) {
2563             register U8 *send = s + len;
2564
2565             if (PL_op->op_private & OPpLOCALE) {
2566                 TAINT;
2567                 SvTAINTED_on(sv);
2568                 for (; s < send; s++)
2569                     *s = toLOWER_LC(*s);
2570             }
2571             else {
2572                 for (; s < send; s++)
2573                     *s = toLOWER(*s);
2574             }
2575         }
2576     }
2577     if (SvSMAGICAL(sv))
2578         mg_set(sv);
2579     RETURN;
2580 }
2581
2582 PP(pp_quotemeta)
2583 {
2584     djSP; dTARGET;
2585     SV *sv = TOPs;
2586     STRLEN len;
2587     register char *s = SvPV(sv,len);
2588     register char *d;
2589
2590     SvUTF8_off(TARG);                           /* decontaminate */
2591     if (len) {
2592         (void)SvUPGRADE(TARG, SVt_PV);
2593         SvGROW(TARG, (len * 2) + 1);
2594         d = SvPVX(TARG);
2595         if (DO_UTF8(sv)) {
2596             while (len) {
2597                 if (*s & 0x80) {
2598                     STRLEN ulen = UTF8SKIP(s);
2599                     if (ulen > len)
2600                         ulen = len;
2601                     len -= ulen;
2602                     while (ulen--)
2603                         *d++ = *s++;
2604                 }
2605                 else {
2606                     if (!isALNUM(*s))
2607                         *d++ = '\\';
2608                     *d++ = *s++;
2609                     len--;
2610                 }
2611             }
2612             SvUTF8_on(TARG);
2613         }
2614         else {
2615             while (len--) {
2616                 if (!isALNUM(*s))
2617                     *d++ = '\\';
2618                 *d++ = *s++;
2619             }
2620         }
2621         *d = '\0';
2622         SvCUR_set(TARG, d - SvPVX(TARG));
2623         (void)SvPOK_only_UTF8(TARG);
2624     }
2625     else
2626         sv_setpvn(TARG, s, len);
2627     SETs(TARG);
2628     if (SvSMAGICAL(TARG))
2629         mg_set(TARG);
2630     RETURN;
2631 }
2632
2633 /* Arrays. */
2634
2635 PP(pp_aslice)
2636 {
2637     djSP; dMARK; dORIGMARK;
2638     register SV** svp;
2639     register AV* av = (AV*)POPs;
2640     register I32 lval = PL_op->op_flags & OPf_MOD;
2641     I32 arybase = PL_curcop->cop_arybase;
2642     I32 elem;
2643
2644     if (SvTYPE(av) == SVt_PVAV) {
2645         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2646             I32 max = -1;
2647             for (svp = MARK + 1; svp <= SP; svp++) {
2648                 elem = SvIVx(*svp);
2649                 if (elem > max)
2650                     max = elem;
2651             }
2652             if (max > AvMAX(av))
2653                 av_extend(av, max);
2654         }
2655         while (++MARK <= SP) {
2656             elem = SvIVx(*MARK);
2657
2658             if (elem > 0)
2659                 elem -= arybase;
2660             svp = av_fetch(av, elem, lval);
2661             if (lval) {
2662                 if (!svp || *svp == &PL_sv_undef)
2663                     DIE(aTHX_ PL_no_aelem, elem);
2664                 if (PL_op->op_private & OPpLVAL_INTRO)
2665                     save_aelem(av, elem, svp);
2666             }
2667             *MARK = svp ? *svp : &PL_sv_undef;
2668         }
2669     }
2670     if (GIMME != G_ARRAY) {
2671         MARK = ORIGMARK;
2672         *++MARK = *SP;
2673         SP = MARK;
2674     }
2675     RETURN;
2676 }
2677
2678 /* Associative arrays. */
2679
2680 PP(pp_each)
2681 {
2682     djSP;
2683     HV *hash = (HV*)POPs;
2684     HE *entry;
2685     I32 gimme = GIMME_V;
2686     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2687
2688     PUTBACK;
2689     /* might clobber stack_sp */
2690     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2691     SPAGAIN;
2692
2693     EXTEND(SP, 2);
2694     if (entry) {
2695         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2696         if (SvUTF8((SV*)hash))
2697             SvUTF8_on(TOPs);
2698         if (gimme == G_ARRAY) {
2699             SV *val;
2700             PUTBACK;
2701             /* might clobber stack_sp */
2702             val = realhv ?
2703                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2704             SPAGAIN;
2705             PUSHs(val);
2706         }
2707     }
2708     else if (gimme == G_SCALAR)
2709         RETPUSHUNDEF;
2710
2711     RETURN;
2712 }
2713
2714 PP(pp_values)
2715 {
2716     return do_kv();
2717 }
2718
2719 PP(pp_keys)
2720 {
2721     return do_kv();
2722 }
2723
2724 PP(pp_delete)
2725 {
2726     djSP;
2727     I32 gimme = GIMME_V;
2728     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2729     SV *sv;
2730     HV *hv;
2731
2732     if (PL_op->op_private & OPpSLICE) {
2733         dMARK; dORIGMARK;
2734         U32 hvtype;
2735         hv = (HV*)POPs;
2736         hvtype = SvTYPE(hv);
2737         if (hvtype == SVt_PVHV) {                       /* hash element */
2738             while (++MARK <= SP) {
2739                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2740                 *MARK = sv ? sv : &PL_sv_undef;
2741             }
2742         }
2743         else if (hvtype == SVt_PVAV) {
2744             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
2745                 while (++MARK <= SP) {
2746                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2747                     *MARK = sv ? sv : &PL_sv_undef;
2748                 }
2749             }
2750             else {                                      /* pseudo-hash element */
2751                 while (++MARK <= SP) {
2752                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2753                     *MARK = sv ? sv : &PL_sv_undef;
2754                 }
2755             }
2756         }
2757         else
2758             DIE(aTHX_ "Not a HASH reference");
2759         if (discard)
2760             SP = ORIGMARK;
2761         else if (gimme == G_SCALAR) {
2762             MARK = ORIGMARK;
2763             *++MARK = *SP;
2764             SP = MARK;
2765         }
2766     }
2767     else {
2768         SV *keysv = POPs;
2769         hv = (HV*)POPs;
2770         if (SvTYPE(hv) == SVt_PVHV)
2771             sv = hv_delete_ent(hv, keysv, discard, 0);
2772         else if (SvTYPE(hv) == SVt_PVAV) {
2773             if (PL_op->op_flags & OPf_SPECIAL)
2774                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2775             else
2776                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2777         }
2778         else
2779             DIE(aTHX_ "Not a HASH reference");
2780         if (!sv)
2781             sv = &PL_sv_undef;
2782         if (!discard)
2783             PUSHs(sv);
2784     }
2785     RETURN;
2786 }
2787
2788 PP(pp_exists)
2789 {
2790     djSP;
2791     SV *tmpsv;
2792     HV *hv;
2793
2794     if (PL_op->op_private & OPpEXISTS_SUB) {
2795         GV *gv;
2796         CV *cv;
2797         SV *sv = POPs;
2798         cv = sv_2cv(sv, &hv, &gv, FALSE);
2799         if (cv)
2800             RETPUSHYES;
2801         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2802             RETPUSHYES;
2803         RETPUSHNO;
2804     }
2805     tmpsv = POPs;
2806     hv = (HV*)POPs;
2807     if (SvTYPE(hv) == SVt_PVHV) {
2808         if (hv_exists_ent(hv, tmpsv, 0))
2809             RETPUSHYES;
2810     }
2811     else if (SvTYPE(hv) == SVt_PVAV) {
2812         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
2813             if (av_exists((AV*)hv, SvIV(tmpsv)))
2814                 RETPUSHYES;
2815         }
2816         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
2817             RETPUSHYES;
2818     }
2819     else {
2820         DIE(aTHX_ "Not a HASH reference");
2821     }
2822     RETPUSHNO;
2823 }
2824
2825 PP(pp_hslice)
2826 {
2827     djSP; dMARK; dORIGMARK;
2828     register HV *hv = (HV*)POPs;
2829     register I32 lval = PL_op->op_flags & OPf_MOD;
2830     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2831
2832     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2833         DIE(aTHX_ "Can't localize pseudo-hash element");
2834
2835     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2836         while (++MARK <= SP) {
2837             SV *keysv = *MARK;
2838             SV **svp;
2839             if (realhv) {
2840                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2841                 svp = he ? &HeVAL(he) : 0;
2842             }
2843             else {
2844                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2845             }
2846             if (lval) {
2847                 if (!svp || *svp == &PL_sv_undef) {
2848                     STRLEN n_a;
2849                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2850                 }
2851                 if (PL_op->op_private & OPpLVAL_INTRO)
2852                     save_helem(hv, keysv, svp);
2853             }
2854             *MARK = svp ? *svp : &PL_sv_undef;
2855         }
2856     }
2857     if (GIMME != G_ARRAY) {
2858         MARK = ORIGMARK;
2859         *++MARK = *SP;
2860         SP = MARK;
2861     }
2862     RETURN;
2863 }
2864
2865 /* List operators. */
2866
2867 PP(pp_list)
2868 {
2869     djSP; dMARK;
2870     if (GIMME != G_ARRAY) {
2871         if (++MARK <= SP)
2872             *MARK = *SP;                /* unwanted list, return last item */
2873         else
2874             *MARK = &PL_sv_undef;
2875         SP = MARK;
2876     }
2877     RETURN;
2878 }
2879
2880 PP(pp_lslice)
2881 {
2882     djSP;
2883     SV **lastrelem = PL_stack_sp;
2884     SV **lastlelem = PL_stack_base + POPMARK;
2885     SV **firstlelem = PL_stack_base + POPMARK + 1;
2886     register SV **firstrelem = lastlelem + 1;
2887     I32 arybase = PL_curcop->cop_arybase;
2888     I32 lval = PL_op->op_flags & OPf_MOD;
2889     I32 is_something_there = lval;
2890
2891     register I32 max = lastrelem - lastlelem;
2892     register SV **lelem;
2893     register I32 ix;
2894
2895     if (GIMME != G_ARRAY) {
2896         ix = SvIVx(*lastlelem);
2897         if (ix < 0)
2898             ix += max;
2899         else
2900             ix -= arybase;
2901         if (ix < 0 || ix >= max)
2902             *firstlelem = &PL_sv_undef;
2903         else
2904             *firstlelem = firstrelem[ix];
2905         SP = firstlelem;
2906         RETURN;
2907     }
2908
2909     if (max == 0) {
2910         SP = firstlelem - 1;
2911         RETURN;
2912     }
2913
2914     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2915         ix = SvIVx(*lelem);
2916         if (ix < 0)
2917             ix += max;
2918         else
2919             ix -= arybase;
2920         if (ix < 0 || ix >= max)
2921             *lelem = &PL_sv_undef;
2922         else {
2923             is_something_there = TRUE;
2924             if (!(*lelem = firstrelem[ix]))
2925                 *lelem = &PL_sv_undef;
2926         }
2927     }
2928     if (is_something_there)
2929         SP = lastlelem;
2930     else
2931         SP = firstlelem - 1;
2932     RETURN;
2933 }
2934
2935 PP(pp_anonlist)
2936 {
2937     djSP; dMARK; dORIGMARK;
2938     I32 items = SP - MARK;
2939     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2940     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2941     XPUSHs(av);
2942     RETURN;
2943 }
2944
2945 PP(pp_anonhash)
2946 {
2947     djSP; dMARK; dORIGMARK;
2948     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2949
2950     while (MARK < SP) {
2951         SV* key = *++MARK;
2952         SV *val = NEWSV(46, 0);
2953         if (MARK < SP)
2954             sv_setsv(val, *++MARK);
2955         else if (ckWARN(WARN_MISC))
2956             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2957         (void)hv_store_ent(hv,key,val,0);
2958     }
2959     SP = ORIGMARK;
2960     XPUSHs((SV*)hv);
2961     RETURN;
2962 }
2963
2964 PP(pp_splice)
2965 {
2966     djSP; dMARK; dORIGMARK;
2967     register AV *ary = (AV*)*++MARK;
2968     register SV **src;
2969     register SV **dst;
2970     register I32 i;
2971     register I32 offset;
2972     register I32 length;
2973     I32 newlen;
2974     I32 after;
2975     I32 diff;
2976     SV **tmparyval = 0;
2977     MAGIC *mg;
2978
2979     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2980         *MARK-- = SvTIED_obj((SV*)ary, mg);
2981         PUSHMARK(MARK);
2982         PUTBACK;
2983         ENTER;
2984         call_method("SPLICE",GIMME_V);
2985         LEAVE;
2986         SPAGAIN;
2987         RETURN;
2988     }
2989
2990     SP++;
2991
2992     if (++MARK < SP) {
2993         offset = i = SvIVx(*MARK);
2994         if (offset < 0)
2995             offset += AvFILLp(ary) + 1;
2996         else
2997             offset -= PL_curcop->cop_arybase;
2998         if (offset < 0)
2999             DIE(aTHX_ PL_no_aelem, i);
3000         if (++MARK < SP) {
3001             length = SvIVx(*MARK++);
3002             if (length < 0) {
3003                 length += AvFILLp(ary) - offset + 1;
3004                 if (length < 0)
3005                     length = 0;
3006             }
3007         }
3008         else
3009             length = AvMAX(ary) + 1;            /* close enough to infinity */
3010     }
3011     else {
3012         offset = 0;
3013         length = AvMAX(ary) + 1;
3014     }
3015     if (offset > AvFILLp(ary) + 1)
3016         offset = AvFILLp(ary) + 1;
3017     after = AvFILLp(ary) + 1 - (offset + length);
3018     if (after < 0) {                            /* not that much array */
3019         length += after;                        /* offset+length now in array */
3020         after = 0;
3021         if (!AvALLOC(ary))
3022             av_extend(ary, 0);
3023     }
3024
3025     /* At this point, MARK .. SP-1 is our new LIST */
3026
3027     newlen = SP - MARK;
3028     diff = newlen - length;
3029     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3030         av_reify(ary);
3031
3032     if (diff < 0) {                             /* shrinking the area */
3033         if (newlen) {
3034             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3035             Copy(MARK, tmparyval, newlen, SV*);
3036         }
3037
3038         MARK = ORIGMARK + 1;
3039         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3040             MEXTEND(MARK, length);
3041             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3042             if (AvREAL(ary)) {
3043                 EXTEND_MORTAL(length);
3044                 for (i = length, dst = MARK; i; i--) {
3045                     sv_2mortal(*dst);   /* free them eventualy */
3046                     dst++;
3047                 }
3048             }
3049             MARK += length - 1;
3050         }
3051         else {
3052             *MARK = AvARRAY(ary)[offset+length-1];
3053             if (AvREAL(ary)) {
3054                 sv_2mortal(*MARK);
3055                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3056                     SvREFCNT_dec(*dst++);       /* free them now */
3057             }
3058         }
3059         AvFILLp(ary) += diff;
3060
3061         /* pull up or down? */
3062
3063         if (offset < after) {                   /* easier to pull up */
3064             if (offset) {                       /* esp. if nothing to pull */
3065                 src = &AvARRAY(ary)[offset-1];
3066                 dst = src - diff;               /* diff is negative */
3067                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3068                     *dst-- = *src--;
3069             }
3070             dst = AvARRAY(ary);
3071             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3072             AvMAX(ary) += diff;
3073         }
3074         else {
3075             if (after) {                        /* anything to pull down? */
3076                 src = AvARRAY(ary) + offset + length;
3077                 dst = src + diff;               /* diff is negative */
3078                 Move(src, dst, after, SV*);
3079             }
3080             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3081                                                 /* avoid later double free */
3082         }
3083         i = -diff;
3084         while (i)
3085             dst[--i] = &PL_sv_undef;
3086
3087         if (newlen) {
3088             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3089               newlen; newlen--) {
3090                 *dst = NEWSV(46, 0);
3091                 sv_setsv(*dst++, *src++);
3092             }
3093             Safefree(tmparyval);
3094         }
3095     }
3096     else {                                      /* no, expanding (or same) */
3097         if (length) {
3098             New(452, tmparyval, length, SV*);   /* so remember deletion */
3099             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3100         }
3101
3102         if (diff > 0) {                         /* expanding */
3103
3104             /* push up or down? */
3105
3106             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3107                 if (offset) {
3108                     src = AvARRAY(ary);
3109                     dst = src - diff;
3110                     Move(src, dst, offset, SV*);
3111                 }
3112                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3113                 AvMAX(ary) += diff;
3114                 AvFILLp(ary) += diff;
3115             }
3116             else {
3117                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3118                     av_extend(ary, AvFILLp(ary) + diff);
3119                 AvFILLp(ary) += diff;
3120
3121                 if (after) {
3122                     dst = AvARRAY(ary) + AvFILLp(ary);
3123                     src = dst - diff;
3124                     for (i = after; i; i--) {
3125                         *dst-- = *src--;
3126                     }
3127                 }
3128             }
3129         }
3130
3131         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3132             *dst = NEWSV(46, 0);
3133             sv_setsv(*dst++, *src++);
3134         }
3135         MARK = ORIGMARK + 1;
3136         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3137             if (length) {
3138                 Copy(tmparyval, MARK, length, SV*);
3139                 if (AvREAL(ary)) {
3140                     EXTEND_MORTAL(length);
3141                     for (i = length, dst = MARK; i; i--) {
3142                         sv_2mortal(*dst);       /* free them eventualy */
3143                         dst++;
3144                     }
3145                 }
3146                 Safefree(tmparyval);
3147             }
3148             MARK += length - 1;
3149         }
3150         else if (length--) {
3151             *MARK = tmparyval[length];
3152             if (AvREAL(ary)) {
3153                 sv_2mortal(*MARK);
3154                 while (length-- > 0)
3155                     SvREFCNT_dec(tmparyval[length]);
3156             }
3157             Safefree(tmparyval);
3158         }
3159         else
3160             *MARK = &PL_sv_undef;
3161     }
3162     SP = MARK;
3163     RETURN;
3164 }
3165
3166 PP(pp_push)
3167 {
3168     djSP; dMARK; dORIGMARK; dTARGET;
3169     register AV *ary = (AV*)*++MARK;
3170     register SV *sv = &PL_sv_undef;
3171     MAGIC *mg;
3172
3173     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3174         *MARK-- = SvTIED_obj((SV*)ary, mg);
3175         PUSHMARK(MARK);
3176         PUTBACK;
3177         ENTER;
3178         call_method("PUSH",G_SCALAR|G_DISCARD);
3179         LEAVE;
3180         SPAGAIN;
3181     }
3182     else {
3183         /* Why no pre-extend of ary here ? */
3184         for (++MARK; MARK <= SP; MARK++) {
3185             sv = NEWSV(51, 0);
3186             if (*MARK)
3187                 sv_setsv(sv, *MARK);
3188             av_push(ary, sv);
3189         }
3190     }
3191     SP = ORIGMARK;
3192     PUSHi( AvFILL(ary) + 1 );
3193     RETURN;
3194 }
3195
3196 PP(pp_pop)
3197 {
3198     djSP;
3199     AV *av = (AV*)POPs;
3200     SV *sv = av_pop(av);
3201     if (AvREAL(av))
3202         (void)sv_2mortal(sv);
3203     PUSHs(sv);
3204     RETURN;
3205 }
3206
3207 PP(pp_shift)
3208 {
3209     djSP;
3210     AV *av = (AV*)POPs;
3211     SV *sv = av_shift(av);
3212     EXTEND(SP, 1);
3213     if (!sv)
3214         RETPUSHUNDEF;
3215     if (AvREAL(av))
3216         (void)sv_2mortal(sv);
3217     PUSHs(sv);
3218     RETURN;
3219 }
3220
3221 PP(pp_unshift)
3222 {
3223     djSP; dMARK; dORIGMARK; dTARGET;
3224     register AV *ary = (AV*)*++MARK;
3225     register SV *sv;
3226     register I32 i = 0;
3227     MAGIC *mg;
3228
3229     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3230         *MARK-- = SvTIED_obj((SV*)ary, mg);
3231         PUSHMARK(MARK);
3232         PUTBACK;
3233         ENTER;
3234         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3235         LEAVE;
3236         SPAGAIN;
3237     }
3238     else {
3239         av_unshift(ary, SP - MARK);
3240         while (MARK < SP) {
3241             sv = NEWSV(27, 0);
3242             sv_setsv(sv, *++MARK);
3243             (void)av_store(ary, i++, sv);
3244         }
3245     }
3246     SP = ORIGMARK;
3247     PUSHi( AvFILL(ary) + 1 );
3248     RETURN;
3249 }
3250
3251 PP(pp_reverse)
3252 {
3253     djSP; dMARK;
3254     register SV *tmp;
3255     SV **oldsp = SP;
3256
3257     if (GIMME == G_ARRAY) {
3258         MARK++;
3259         while (MARK < SP) {
3260             tmp = *MARK;
3261             *MARK++ = *SP;
3262             *SP-- = tmp;
3263         }
3264         /* safe as long as stack cannot get extended in the above */
3265         SP = oldsp;
3266     }
3267     else {
3268         register char *up;
3269         register char *down;
3270         register I32 tmp;
3271         dTARGET;
3272         STRLEN len;
3273
3274         SvUTF8_off(TARG);                               /* decontaminate */
3275         if (SP - MARK > 1)
3276             do_join(TARG, &PL_sv_no, MARK, SP);
3277         else
3278             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3279         up = SvPV_force(TARG, len);
3280         if (len > 1) {
3281             if (DO_UTF8(TARG)) {        /* first reverse each character */
3282                 U8* s = (U8*)SvPVX(TARG);
3283                 U8* send = (U8*)(s + len);
3284                 while (s < send) {
3285                     if (*s < 0x80) {
3286                         s++;
3287                         continue;
3288                     }
3289                     else {
3290                         up = (char*)s;
3291                         s += UTF8SKIP(s);
3292                         down = (char*)(s - 1);
3293                         if (s > send || !((*down & 0xc0) == 0x80)) {
3294                             if (ckWARN_d(WARN_UTF8))
3295                                 Perl_warner(aTHX_ WARN_UTF8,
3296                                             "Malformed UTF-8 character");
3297                             break;
3298                         }
3299                         while (down > up) {
3300                             tmp = *up;
3301                             *up++ = *down;
3302                             *down-- = tmp;
3303                         }
3304                     }
3305                 }
3306                 up = SvPVX(TARG);
3307             }
3308             down = SvPVX(TARG) + len - 1;
3309             while (down > up) {
3310                 tmp = *up;
3311                 *up++ = *down;
3312                 *down-- = tmp;
3313             }
3314             (void)SvPOK_only_UTF8(TARG);
3315         }
3316         SP = MARK + 1;
3317         SETTARG;
3318     }
3319     RETURN;
3320 }
3321
3322 STATIC SV *
3323 S_mul128(pTHX_ SV *sv, U8 m)
3324 {
3325   STRLEN          len;
3326   char           *s = SvPV(sv, len);
3327   char           *t;
3328   U32             i = 0;
3329
3330   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3331     SV             *tmpNew = newSVpvn("0000000000", 10);
3332
3333     sv_catsv(tmpNew, sv);
3334     SvREFCNT_dec(sv);           /* free old sv */
3335     sv = tmpNew;
3336     s = SvPV(sv, len);
3337   }
3338   t = s + len - 1;
3339   while (!*t)                   /* trailing '\0'? */
3340     t--;
3341   while (t > s) {
3342     i = ((*t - '0') << 7) + m;
3343     *(t--) = '0' + (i % 10);
3344     m = i / 10;
3345   }
3346   return (sv);
3347 }
3348
3349 /* Explosives and implosives. */
3350
3351 #if 'I' == 73 && 'J' == 74
3352 /* On an ASCII/ISO kind of system */
3353 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3354 #else
3355 /*
3356   Some other sort of character set - use memchr() so we don't match
3357   the null byte.
3358  */
3359 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3360 #endif
3361
3362 PP(pp_unpack)
3363 {
3364     djSP;
3365     dPOPPOPssrl;
3366     I32 start_sp_offset = SP - PL_stack_base;
3367     I32 gimme = GIMME_V;
3368     SV *sv;
3369     STRLEN llen;
3370     STRLEN rlen;
3371     register char *pat = SvPV(left, llen);
3372     register char *s = SvPV(right, rlen);
3373     char *strend = s + rlen;
3374     char *strbeg = s;
3375     register char *patend = pat + llen;
3376     I32 datumtype;
3377     register I32 len;
3378     register I32 bits;
3379     register char *str;
3380
3381     /* These must not be in registers: */
3382     short ashort;
3383     int aint;
3384     long along;
3385 #ifdef HAS_QUAD
3386     Quad_t aquad;
3387 #endif
3388     U16 aushort;
3389     unsigned int auint;
3390     U32 aulong;
3391 #ifdef HAS_QUAD
3392     Uquad_t auquad;
3393 #endif
3394     char *aptr;
3395     float afloat;
3396     double adouble;
3397     I32 checksum = 0;
3398     register U32 culong;
3399     NV cdouble;
3400     int commas = 0;
3401     int star;
3402 #ifdef PERL_NATINT_PACK
3403     int natint;         /* native integer */
3404     int unatint;        /* unsigned native integer */
3405 #endif
3406
3407     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3408         /*SUPPRESS 530*/
3409         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3410         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3411             patend++;
3412             while (isDIGIT(*patend) || *patend == '*')
3413                 patend++;
3414         }
3415         else
3416             patend++;
3417     }
3418     while (pat < patend) {
3419       reparse:
3420         datumtype = *pat++ & 0xFF;
3421 #ifdef PERL_NATINT_PACK
3422         natint = 0;
3423 #endif
3424         if (isSPACE(datumtype))
3425             continue;
3426         if (datumtype == '#') {
3427             while (pat < patend && *pat != '\n')
3428                 pat++;
3429             continue;
3430         }
3431         if (*pat == '!') {
3432             char *natstr = "sSiIlL";
3433
3434             if (strchr(natstr, datumtype)) {
3435 #ifdef PERL_NATINT_PACK
3436                 natint = 1;
3437 #endif
3438                 pat++;
3439             }
3440             else
3441                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3442         }
3443         star = 0;
3444         if (pat >= patend)
3445             len = 1;
3446         else if (*pat == '*') {
3447             len = strend - strbeg;      /* long enough */
3448             pat++;
3449             star = 1;
3450         }
3451         else if (isDIGIT(*pat)) {
3452             len = *pat++ - '0';
3453             while (isDIGIT(*pat)) {
3454                 len = (len * 10) + (*pat++ - '0');
3455                 if (len < 0)
3456                     DIE(aTHX_ "Repeat count in unpack overflows");
3457             }
3458         }
3459         else
3460             len = (datumtype != '@');
3461       redo_switch:
3462         switch(datumtype) {
3463         default:
3464             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3465         case ',': /* grandfather in commas but with a warning */
3466             if (commas++ == 0 && ckWARN(WARN_UNPACK))
3467                 Perl_warner(aTHX_ WARN_UNPACK,
3468                             "Invalid type in unpack: '%c'", (int)datumtype);
3469             break;
3470         case '%':
3471             if (len == 1 && pat[-1] != '1')
3472                 len = 16;
3473             checksum = len;
3474             culong = 0;
3475             cdouble = 0;
3476             if (pat < patend)
3477                 goto reparse;
3478             break;
3479         case '@':
3480             if (len > strend - strbeg)
3481                 DIE(aTHX_ "@ outside of string");
3482             s = strbeg + len;
3483             break;
3484         case 'X':
3485             if (len > s - strbeg)
3486                 DIE(aTHX_ "X outside of string");
3487             s -= len;
3488             break;
3489         case 'x':
3490             if (len > strend - s)
3491                 DIE(aTHX_ "x outside of string");
3492             s += len;
3493             break;
3494         case '/':
3495             if (start_sp_offset >= SP - PL_stack_base)
3496                 DIE(aTHX_ "/ must follow a numeric type");
3497             datumtype = *pat++;
3498             if (*pat == '*')
3499                 pat++;          /* ignore '*' for compatibility with pack */
3500             if (isDIGIT(*pat))
3501                 DIE(aTHX_ "/ cannot take a count" );
3502             len = POPi;
3503             star = 0;
3504             goto redo_switch;
3505         case 'A':
3506         case 'Z':
3507         case 'a':
3508             if (len > strend - s)
3509                 len = strend - s;
3510             if (checksum)
3511                 goto uchar_checksum;
3512             sv = NEWSV(35, len);
3513             sv_setpvn(sv, s, len);
3514             s += len;
3515             if (datumtype == 'A' || datumtype == 'Z') {
3516                 aptr = s;       /* borrow register */
3517                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3518                     s = SvPVX(sv);
3519                     while (*s)
3520                         s++;
3521                 }
3522                 else {          /* 'A' strips both nulls and spaces */
3523                     s = SvPVX(sv) + len - 1;
3524                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3525                         s--;
3526                     *++s = '\0';
3527                 }
3528                 SvCUR_set(sv, s - SvPVX(sv));
3529                 s = aptr;       /* unborrow register */
3530             }
3531             XPUSHs(sv_2mortal(sv));
3532             break;
3533         case 'B':
3534         case 'b':
3535             if (star || len > (strend - s) * 8)
3536                 len = (strend - s) * 8;
3537             if (checksum) {
3538                 if (!PL_bitcount) {
3539                     Newz(601, PL_bitcount, 256, char);
3540                     for (bits = 1; bits < 256; bits++) {
3541                         if (bits & 1)   PL_bitcount[bits]++;
3542                         if (bits & 2)   PL_bitcount[bits]++;
3543                         if (bits & 4)   PL_bitcount[bits]++;
3544                         if (bits & 8)   PL_bitcount[bits]++;
3545                         if (bits & 16)  PL_bitcount[bits]++;
3546                         if (bits & 32)  PL_bitcount[bits]++;
3547                         if (bits & 64)  PL_bitcount[bits]++;
3548                         if (bits & 128) PL_bitcount[bits]++;
3549                     }
3550                 }
3551                 while (len >= 8) {
3552                     culong += PL_bitcount[*(unsigned char*)s++];
3553                     len -= 8;
3554                 }
3555                 if (len) {
3556                     bits = *s;
3557                     if (datumtype == 'b') {
3558                         while (len-- > 0) {
3559                             if (bits & 1) culong++;
3560                             bits >>= 1;
3561                         }
3562                     }
3563                     else {
3564                         while (len-- > 0) {
3565                             if (bits & 128) culong++;
3566                             bits <<= 1;
3567                         }
3568                     }
3569                 }
3570                 break;
3571             }
3572             sv = NEWSV(35, len + 1);
3573             SvCUR_set(sv, len);
3574             SvPOK_on(sv);
3575             str = SvPVX(sv);
3576             if (datumtype == 'b') {
3577                 aint = len;
3578                 for (len = 0; len < aint; len++) {
3579                     if (len & 7)                /*SUPPRESS 595*/
3580                         bits >>= 1;
3581                     else
3582                         bits = *s++;
3583                     *str++ = '0' + (bits & 1);
3584                 }
3585             }
3586             else {
3587                 aint = len;
3588                 for (len = 0; len < aint; len++) {
3589                     if (len & 7)
3590                         bits <<= 1;
3591                     else
3592                         bits = *s++;
3593                     *str++ = '0' + ((bits & 128) != 0);
3594                 }
3595             }
3596             *str = '\0';
3597             XPUSHs(sv_2mortal(sv));
3598             break;
3599         case 'H':
3600         case 'h':
3601             if (star || len > (strend - s) * 2)
3602                 len = (strend - s) * 2;
3603             sv = NEWSV(35, len + 1);
3604             SvCUR_set(sv, len);
3605             SvPOK_on(sv);
3606             str = SvPVX(sv);
3607             if (datumtype == 'h') {
3608                 aint = len;
3609                 for (len = 0; len < aint; len++) {
3610                     if (len & 1)
3611                         bits >>= 4;
3612                     else
3613                         bits = *s++;
3614                     *str++ = PL_hexdigit[bits & 15];
3615                 }
3616             }
3617             else {
3618                 aint = len;
3619                 for (len = 0; len < aint; len++) {
3620                     if (len & 1)
3621                         bits <<= 4;
3622                     else
3623                         bits = *s++;
3624                     *str++ = PL_hexdigit[(bits >> 4) & 15];
3625                 }
3626             }
3627             *str = '\0';
3628             XPUSHs(sv_2mortal(sv));
3629             break;
3630         case 'c':
3631             if (len > strend - s)
3632                 len = strend - s;
3633             if (checksum) {
3634                 while (len-- > 0) {
3635                     aint = *s++;
3636                     if (aint >= 128)    /* fake up signed chars */
3637                         aint -= 256;
3638                     culong += aint;
3639                 }
3640             }
3641             else {
3642                 EXTEND(SP, len);
3643                 EXTEND_MORTAL(len);
3644                 while (len-- > 0) {
3645                     aint = *s++;
3646                     if (aint >= 128)    /* fake up signed chars */
3647                         aint -= 256;
3648                     sv = NEWSV(36, 0);
3649                     sv_setiv(sv, (IV)aint);
3650                     PUSHs(sv_2mortal(sv));
3651                 }
3652             }
3653             break;
3654         case 'C':
3655             if (len > strend - s)
3656                 len = strend - s;
3657             if (checksum) {
3658               uchar_checksum:
3659                 while (len-- > 0) {
3660                     auint = *s++ & 255;
3661                     culong += auint;
3662                 }
3663             }
3664             else {
3665                 EXTEND(SP, len);
3666                 EXTEND_MORTAL(len);
3667                 while (len-- > 0) {
3668                     auint = *s++ & 255;
3669                     sv = NEWSV(37, 0);
3670                     sv_setiv(sv, (IV)auint);
3671                     PUSHs(sv_2mortal(sv));
3672                 }
3673             }
3674             break;
3675         case 'U':
3676             if (len > strend - s)
3677                 len = strend - s;
3678             if (checksum) {
3679                 while (len-- > 0 && s < strend) {
3680                     STRLEN alen;
3681                     auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3682                     along = alen;
3683                     s += along;
3684                     if (checksum > 32)
3685                         cdouble += (NV)auint;
3686                     else
3687                         culong += auint;
3688                 }
3689             }
3690             else {
3691                 EXTEND(SP, len);
3692                 EXTEND_MORTAL(len);
3693                 while (len-- > 0 && s < strend) {
3694                     STRLEN alen;
3695                     auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3696                     along = alen;
3697                     s += along;
3698                     sv = NEWSV(37, 0);
3699                     sv_setuv(sv, (UV)auint);
3700                     PUSHs(sv_2mortal(sv));
3701                 }
3702             }
3703             break;
3704         case 's':
3705 #if SHORTSIZE == SIZE16
3706             along = (strend - s) / SIZE16;
3707 #else
3708             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3709 #endif
3710             if (len > along)
3711                 len = along;
3712             if (checksum) {
3713 #if SHORTSIZE != SIZE16
3714                 if (natint) {
3715                     short ashort;
3716                     while (len-- > 0) {
3717                         COPYNN(s, &ashort, sizeof(short));
3718                         s += sizeof(short);
3719                         culong += ashort;
3720
3721                     }
3722                 }
3723                 else
3724 #endif
3725                 {
3726                     while (len-- > 0) {
3727                         COPY16(s, &ashort);
3728 #if SHORTSIZE > SIZE16
3729                         if (ashort > 32767)
3730                           ashort -= 65536;
3731 #endif
3732                         s += SIZE16;
3733                         culong += ashort;
3734                     }
3735                 }
3736             }
3737             else {
3738                 EXTEND(SP, len);
3739                 EXTEND_MORTAL(len);
3740 #if SHORTSIZE != SIZE16
3741                 if (natint) {
3742                     short ashort;
3743                     while (len-- > 0) {
3744                         COPYNN(s, &ashort, sizeof(short));
3745                         s += sizeof(short);
3746                         sv = NEWSV(38, 0);
3747                         sv_setiv(sv, (IV)ashort);
3748                         PUSHs(sv_2mortal(sv));
3749                     }
3750                 }
3751                 else
3752 #endif
3753                 {
3754                     while (len-- > 0) {
3755                         COPY16(s, &ashort);
3756 #if SHORTSIZE > SIZE16
3757                         if (ashort > 32767)
3758                           ashort -= 65536;
3759 #endif
3760                         s += SIZE16;
3761                         sv = NEWSV(38, 0);
3762                         sv_setiv(sv, (IV)ashort);
3763                         PUSHs(sv_2mortal(sv));
3764                     }
3765                 }
3766             }
3767             break;
3768         case 'v':
3769         case 'n':
3770         case 'S':
3771 #if SHORTSIZE == SIZE16
3772             along = (strend - s) / SIZE16;
3773 #else
3774             unatint = natint && datumtype == 'S';
3775             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3776 #endif
3777             if (len > along)
3778                 len = along;
3779             if (checksum) {
3780 #if SHORTSIZE != SIZE16
3781                 if (unatint) {
3782                     unsigned short aushort;
3783                     while (len-- > 0) {
3784                         COPYNN(s, &aushort, sizeof(unsigned short));
3785                         s += sizeof(unsigned short);
3786                         culong += aushort;
3787                     }
3788                 }
3789                 else
3790 #endif
3791                 {
3792                     while (len-- > 0) {
3793                         COPY16(s, &aushort);
3794                         s += SIZE16;
3795 #ifdef HAS_NTOHS
3796                         if (datumtype == 'n')
3797                             aushort = PerlSock_ntohs(aushort);
3798 #endif
3799 #ifdef HAS_VTOHS
3800                         if (datumtype == 'v')
3801                             aushort = vtohs(aushort);
3802 #endif
3803                         culong += aushort;
3804                     }
3805                 }
3806             }
3807             else {
3808                 EXTEND(SP, len);
3809                 EXTEND_MORTAL(len);
3810 #if SHORTSIZE != SIZE16
3811                 if (unatint) {
3812                     unsigned short aushort;
3813                     while (len-- > 0) {
3814                         COPYNN(s, &aushort, sizeof(unsigned short));
3815                         s += sizeof(unsigned short);
3816                         sv = NEWSV(39, 0);
3817                         sv_setiv(sv, (UV)aushort);
3818                         PUSHs(sv_2mortal(sv));
3819                     }
3820                 }
3821                 else
3822 #endif
3823                 {
3824                     while (len-- > 0) {
3825                         COPY16(s, &aushort);
3826                         s += SIZE16;
3827                         sv = NEWSV(39, 0);
3828 #ifdef HAS_NTOHS
3829                         if (datumtype == 'n')
3830                             aushort = PerlSock_ntohs(aushort);
3831 #endif
3832 #ifdef HAS_VTOHS
3833                         if (datumtype == 'v')
3834                             aushort = vtohs(aushort);
3835 #endif
3836                         sv_setiv(sv, (UV)aushort);
3837                         PUSHs(sv_2mortal(sv));
3838                     }
3839                 }
3840             }
3841             break;
3842         case 'i':
3843             along = (strend - s) / sizeof(int);
3844             if (len > along)
3845                 len = along;
3846             if (checksum) {
3847                 while (len-- > 0) {
3848                     Copy(s, &aint, 1, int);
3849                     s += sizeof(int);
3850                     if (checksum > 32)
3851                         cdouble += (NV)aint;
3852                     else
3853                         culong += aint;
3854                 }
3855             }
3856             else {
3857                 EXTEND(SP, len);
3858                 EXTEND_MORTAL(len);
3859                 while (len-- > 0) {
3860                     Copy(s, &aint, 1, int);
3861                     s += sizeof(int);
3862                     sv = NEWSV(40, 0);
3863 #ifdef __osf__
3864                     /* Without the dummy below unpack("i", pack("i",-1))
3865                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3866                      * cc with optimization turned on.
3867                      *
3868                      * The bug was detected in
3869                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3870                      * with optimization (-O4) turned on.
3871                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3872                      * does not have this problem even with -O4.
3873                      *
3874                      * This bug was reported as DECC_BUGS 1431
3875                      * and tracked internally as GEM_BUGS 7775.
3876                      *
3877                      * The bug is fixed in
3878                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3879                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3880                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3881                      * and also in DTK.
3882                      *
3883                      * See also few lines later for the same bug.
3884                      */
3885                     (aint) ?
3886                         sv_setiv(sv, (IV)aint) :
3887 #endif
3888                     sv_setiv(sv, (IV)aint);
3889                     PUSHs(sv_2mortal(sv));
3890                 }
3891             }
3892             break;
3893         case 'I':
3894             along = (strend - s) / sizeof(unsigned int);
3895             if (len > along)
3896                 len = along;
3897             if (checksum) {
3898                 while (len-- > 0) {
3899                     Copy(s, &auint, 1, unsigned int);
3900                     s += sizeof(unsigned int);
3901                     if (checksum > 32)
3902                         cdouble += (NV)auint;
3903                     else
3904                         culong += auint;
3905                 }
3906             }
3907             else {
3908                 EXTEND(SP, len);
3909                 EXTEND_MORTAL(len);
3910                 while (len-- > 0) {
3911                     Copy(s, &auint, 1, unsigned int);
3912                     s += sizeof(unsigned int);
3913                     sv = NEWSV(41, 0);
3914 #ifdef __osf__
3915                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3916                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3917                      * See details few lines earlier. */
3918                     (auint) ?
3919                         sv_setuv(sv, (UV)auint) :
3920 #endif
3921                     sv_setuv(sv, (UV)auint);
3922                     PUSHs(sv_2mortal(sv));
3923                 }
3924             }
3925             break;
3926         case 'l':
3927 #if LONGSIZE == SIZE32
3928             along = (strend - s) / SIZE32;
3929 #else
3930             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3931 #endif
3932             if (len > along)
3933                 len = along;
3934             if (checksum) {
3935 #if LONGSIZE != SIZE32
3936                 if (natint) {
3937                     while (len-- > 0) {
3938                         COPYNN(s, &along, sizeof(long));
3939                         s += sizeof(long);
3940                         if (checksum > 32)
3941                             cdouble += (NV)along;
3942                         else
3943                             culong += along;
3944                     }
3945                 }
3946                 else
3947 #endif
3948                 {
3949                     while (len-- > 0) {
3950 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3951                         I32 along;
3952 #endif
3953                         COPY32(s, &along);
3954 #if LONGSIZE > SIZE32
3955                         if (along > 2147483647)
3956                           along -= 4294967296;
3957 #endif
3958                         s += SIZE32;
3959                         if (checksum > 32)
3960                             cdouble += (NV)along;
3961                         else
3962                             culong += along;
3963                     }
3964                 }
3965             }
3966             else {
3967                 EXTEND(SP, len);
3968                 EXTEND_MORTAL(len);
3969 #if LONGSIZE != SIZE32
3970                 if (natint) {
3971                     while (len-- > 0) {
3972                         COPYNN(s, &along, sizeof(long));
3973                         s += sizeof(long);
3974                         sv = NEWSV(42, 0);
3975                         sv_setiv(sv, (IV)along);
3976                         PUSHs(sv_2mortal(sv));
3977                     }
3978                 }
3979                 else
3980 #endif
3981                 {
3982                     while (len-- > 0) {
3983 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3984                         I32 along;
3985 #endif
3986                         COPY32(s, &along);
3987 #if LONGSIZE > SIZE32
3988                         if (along > 2147483647)
3989                           along -= 4294967296;
3990 #endif
3991                         s += SIZE32;
3992                         sv = NEWSV(42, 0);
3993                         sv_setiv(sv, (IV)along);
3994                         PUSHs(sv_2mortal(sv));
3995                     }
3996                 }
3997             }
3998             break;
3999         case 'V':
4000         case 'N':
4001         case 'L':
4002 #if LONGSIZE == SIZE32
4003             along = (strend - s) / SIZE32;
4004 #else
4005             unatint = natint && datumtype == 'L';
4006             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4007 #endif
4008             if (len > along)
4009                 len = along;
4010             if (checksum) {
4011 #if LONGSIZE != SIZE32
4012                 if (unatint) {
4013                     unsigned long aulong;
4014                     while (len-- > 0) {
4015                         COPYNN(s, &aulong, sizeof(unsigned long));
4016                         s += sizeof(unsigned long);
4017                         if (checksum > 32)
4018                             cdouble += (NV)aulong;
4019                         else
4020                             culong += aulong;
4021                     }
4022                 }
4023                 else
4024 #endif
4025                 {
4026                     while (len-- > 0) {
4027                         COPY32(s, &aulong);
4028                         s += SIZE32;
4029 #ifdef HAS_NTOHL
4030                         if (datumtype == 'N')
4031                             aulong = PerlSock_ntohl(aulong);
4032 #endif
4033 #ifdef HAS_VTOHL
4034                         if (datumtype == 'V')
4035                             aulong = vtohl(aulong);
4036 #endif
4037                         if (checksum > 32)
4038                             cdouble += (NV)aulong;
4039                         else
4040                             culong += aulong;
4041                     }
4042                 }
4043             }
4044             else {
4045                 EXTEND(SP, len);
4046                 EXTEND_MORTAL(len);
4047 #if LONGSIZE != SIZE32
4048                 if (unatint) {
4049                     unsigned long aulong;
4050                     while (len-- > 0) {
4051                         COPYNN(s, &aulong, sizeof(unsigned long));
4052                         s += sizeof(unsigned long);
4053                         sv = NEWSV(43, 0);
4054                         sv_setuv(sv, (UV)aulong);
4055                         PUSHs(sv_2mortal(sv));
4056                     }
4057                 }
4058                 else
4059 #endif
4060                 {
4061                     while (len-- > 0) {
4062                         COPY32(s, &aulong);
4063                         s += SIZE32;
4064 #ifdef HAS_NTOHL
4065                         if (datumtype == 'N')
4066                             aulong = PerlSock_ntohl(aulong);
4067 #endif
4068 #ifdef HAS_VTOHL
4069                         if (datumtype == 'V')
4070                             aulong = vtohl(aulong);
4071 #endif
4072                         sv = NEWSV(43, 0);
4073                         sv_setuv(sv, (UV)aulong);
4074                         PUSHs(sv_2mortal(sv));
4075                     }
4076                 }
4077             }
4078             break;
4079         case 'p':
4080             along = (strend - s) / sizeof(char*);
4081             if (len > along)
4082                 len = along;
4083             EXTEND(SP, len);
4084             EXTEND_MORTAL(len);
4085             while (len-- > 0) {
4086                 if (sizeof(char*) > strend - s)
4087                     break;
4088                 else {
4089                     Copy(s, &aptr, 1, char*);
4090                     s += sizeof(char*);
4091                 }
4092                 sv = NEWSV(44, 0);
4093                 if (aptr)
4094                     sv_setpv(sv, aptr);
4095                 PUSHs(sv_2mortal(sv));
4096             }
4097             break;
4098         case 'w':
4099             EXTEND(SP, len);
4100             EXTEND_MORTAL(len);
4101             {
4102                 UV auv = 0;
4103                 U32 bytes = 0;
4104
4105                 while ((len > 0) && (s < strend)) {
4106                     auv = (auv << 7) | (*s & 0x7f);
4107                     if (!(*s++ & 0x80)) {
4108                         bytes = 0;
4109                         sv = NEWSV(40, 0);
4110                         sv_setuv(sv, auv);
4111                         PUSHs(sv_2mortal(sv));
4112                         len--;
4113                         auv = 0;
4114                     }
4115                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4116                         char *t;
4117                         STRLEN n_a;
4118
4119                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4120                         while (s < strend) {
4121                             sv = mul128(sv, *s & 0x7f);
4122                             if (!(*s++ & 0x80)) {
4123                                 bytes = 0;
4124                                 break;
4125                             }
4126                         }
4127                         t = SvPV(sv, n_a);
4128                         while (*t == '0')
4129                             t++;
4130                         sv_chop(sv, t);
4131                         PUSHs(sv_2mortal(sv));
4132                         len--;
4133                         auv = 0;
4134                     }
4135                 }
4136                 if ((s >= strend) && bytes)
4137                     DIE(aTHX_ "Unterminated compressed integer");
4138             }
4139             break;
4140         case 'P':
4141             EXTEND(SP, 1);
4142             if (sizeof(char*) > strend - s)
4143                 break;
4144             else {
4145                 Copy(s, &aptr, 1, char*);
4146                 s += sizeof(char*);
4147             }
4148             sv = NEWSV(44, 0);
4149             if (aptr)
4150                 sv_setpvn(sv, aptr, len);
4151             PUSHs(sv_2mortal(sv));
4152             break;
4153 #ifdef HAS_QUAD
4154         case 'q':
4155             along = (strend - s) / sizeof(Quad_t);
4156             if (len > along)
4157                 len = along;
4158             EXTEND(SP, len);
4159             EXTEND_MORTAL(len);
4160             while (len-- > 0) {
4161                 if (s + sizeof(Quad_t) > strend)
4162                     aquad = 0;
4163                 else {
4164                     Copy(s, &aquad, 1, Quad_t);
4165                     s += sizeof(Quad_t);
4166                 }
4167                 sv = NEWSV(42, 0);
4168                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4169                     sv_setiv(sv, (IV)aquad);
4170                 else
4171                     sv_setnv(sv, (NV)aquad);
4172                 PUSHs(sv_2mortal(sv));
4173             }
4174             break;
4175         case 'Q':
4176             along = (strend - s) / sizeof(Quad_t);
4177             if (len > along)
4178                 len = along;
4179             EXTEND(SP, len);
4180             EXTEND_MORTAL(len);
4181             while (len-- > 0) {
4182                 if (s + sizeof(Uquad_t) > strend)
4183                     auquad = 0;
4184                 else {
4185                     Copy(s, &auquad, 1, Uquad_t);
4186                     s += sizeof(Uquad_t);
4187                 }
4188                 sv = NEWSV(43, 0);
4189                 if (auquad <= UV_MAX)
4190                     sv_setuv(sv, (UV)auquad);
4191                 else
4192                     sv_setnv(sv, (NV)auquad);
4193                 PUSHs(sv_2mortal(sv));
4194             }
4195             break;
4196 #endif
4197         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4198         case 'f':
4199         case 'F':
4200             along = (strend - s) / sizeof(float);
4201             if (len > along)
4202                 len = along;
4203             if (checksum) {
4204                 while (len-- > 0) {
4205                     Copy(s, &afloat, 1, float);
4206                     s += sizeof(float);
4207                     cdouble += afloat;
4208                 }
4209             }
4210             else {
4211                 EXTEND(SP, len);
4212                 EXTEND_MORTAL(len);
4213                 while (len-- > 0) {
4214                     Copy(s, &afloat, 1, float);
4215                     s += sizeof(float);
4216                     sv = NEWSV(47, 0);
4217                     sv_setnv(sv, (NV)afloat);
4218                     PUSHs(sv_2mortal(sv));
4219                 }
4220             }
4221             break;
4222         case 'd':
4223         case 'D':
4224             along = (strend - s) / sizeof(double);
4225             if (len > along)
4226                 len = along;
4227             if (checksum) {
4228                 while (len-- > 0) {
4229                     Copy(s, &adouble, 1, double);
4230                     s += sizeof(double);
4231                     cdouble += adouble;
4232                 }
4233             }
4234             else {
4235                 EXTEND(SP, len);
4236                 EXTEND_MORTAL(len);
4237                 while (len-- > 0) {
4238                     Copy(s, &adouble, 1, double);
4239                     s += sizeof(double);
4240                     sv = NEWSV(48, 0);
4241                     sv_setnv(sv, (NV)adouble);
4242                     PUSHs(sv_2mortal(sv));
4243                 }
4244             }
4245             break;
4246         case 'u':
4247             /* MKS:
4248              * Initialise the decode mapping.  By using a table driven
4249              * algorithm, the code will be character-set independent
4250              * (and just as fast as doing character arithmetic)
4251              */
4252             if (PL_uudmap['M'] == 0) {
4253                 int i;
4254
4255                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4256                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4257                 /*
4258                  * Because ' ' and '`' map to the same value,
4259                  * we need to decode them both the same.
4260                  */
4261                 PL_uudmap[' '] = 0;
4262             }
4263
4264             along = (strend - s) * 3 / 4;
4265             sv = NEWSV(42, along);
4266             if (along)
4267                 SvPOK_on(sv);
4268             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4269                 I32 a, b, c, d;
4270                 char hunk[4];
4271
4272                 hunk[3] = '\0';
4273                 len = PL_uudmap[*(U8*)s++] & 077;
4274                 while (len > 0) {
4275                     if (s < strend && ISUUCHAR(*s))
4276                         a = PL_uudmap[*(U8*)s++] & 077;
4277                     else
4278                         a = 0;
4279                     if (s < strend && ISUUCHAR(*s))
4280                         b = PL_uudmap[*(U8*)s++] & 077;
4281                     else
4282                         b = 0;
4283                     if (s < strend && ISUUCHAR(*s))
4284                         c = PL_uudmap[*(U8*)s++] & 077;
4285                     else
4286                         c = 0;
4287                     if (s < strend && ISUUCHAR(*s))
4288                         d = PL_uudmap[*(U8*)s++] & 077;
4289                     else
4290                         d = 0;
4291                     hunk[0] = (a << 2) | (b >> 4);
4292                     hunk[1] = (b << 4) | (c >> 2);
4293                     hunk[2] = (c << 6) | d;
4294                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4295                     len -= 3;
4296                 }
4297                 if (*s == '\n')
4298                     s++;
4299                 else if (s[1] == '\n')          /* possible checksum byte */
4300                     s += 2;
4301             }
4302             XPUSHs(sv_2mortal(sv));
4303             break;
4304         }
4305         if (checksum) {
4306             sv = NEWSV(42, 0);
4307             if (strchr("fFdD", datumtype) ||
4308               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4309                 NV trouble;
4310
4311                 adouble = 1.0;
4312                 while (checksum >= 16) {
4313                     checksum -= 16;
4314                     adouble *= 65536.0;
4315                 }
4316                 while (checksum >= 4) {
4317                     checksum -= 4;
4318                     adouble *= 16.0;
4319                 }
4320                 while (checksum--)
4321                     adouble *= 2.0;
4322                 along = (1 << checksum) - 1;
4323                 while (cdouble < 0.0)
4324                     cdouble += adouble;
4325                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4326                 sv_setnv(sv, cdouble);
4327             }
4328             else {
4329                 if (checksum < 32) {
4330                     aulong = (1 << checksum) - 1;
4331                     culong &= aulong;
4332                 }
4333                 sv_setuv(sv, (UV)culong);
4334             }
4335             XPUSHs(sv_2mortal(sv));
4336             checksum = 0;
4337         }
4338     }
4339     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4340         PUSHs(&PL_sv_undef);
4341     RETURN;
4342 }
4343
4344 STATIC void
4345 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4346 {
4347     char hunk[5];
4348
4349     *hunk = PL_uuemap[len];
4350     sv_catpvn(sv, hunk, 1);
4351     hunk[4] = '\0';
4352     while (len > 2) {
4353         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4354         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4355         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4356         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4357         sv_catpvn(sv, hunk, 4);
4358         s += 3;
4359         len -= 3;
4360     }
4361     if (len > 0) {
4362         char r = (len > 1 ? s[1] : '\0');
4363         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4364         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4365         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4366         hunk[3] = PL_uuemap[0];
4367         sv_catpvn(sv, hunk, 4);
4368     }
4369     sv_catpvn(sv, "\n", 1);
4370 }
4371
4372 STATIC SV *
4373 S_is_an_int(pTHX_ char *s, STRLEN l)
4374 {
4375   STRLEN         n_a;
4376   SV             *result = newSVpvn(s, l);
4377   char           *result_c = SvPV(result, n_a); /* convenience */
4378   char           *out = result_c;
4379   bool            skip = 1;
4380   bool            ignore = 0;
4381
4382   while (*s) {
4383     switch (*s) {
4384     case ' ':
4385       break;
4386     case '+':
4387       if (!skip) {
4388         SvREFCNT_dec(result);
4389         return (NULL);
4390       }
4391       break;
4392     case '0':
4393     case '1':
4394     case '2':
4395     case '3':
4396     case '4':
4397     case '5':
4398     case '6':
4399     case '7':
4400     case '8':
4401     case '9':
4402       skip = 0;
4403       if (!ignore) {
4404         *(out++) = *s;
4405       }
4406       break;
4407     case '.':
4408       ignore = 1;
4409       break;
4410     default:
4411       SvREFCNT_dec(result);
4412       return (NULL);
4413     }
4414     s++;
4415   }
4416   *(out++) = '\0';
4417   SvCUR_set(result, out - result_c);
4418   return (result);
4419 }
4420
4421 /* pnum must be '\0' terminated */
4422 STATIC int
4423 S_div128(pTHX_ SV *pnum, bool *done)
4424 {
4425   STRLEN          len;
4426   char           *s = SvPV(pnum, len);
4427   int             m = 0;
4428   int             r = 0;
4429   char           *t = s;
4430
4431   *done = 1;
4432   while (*t) {
4433     int             i;
4434
4435     i = m * 10 + (*t - '0');
4436     m = i & 0x7F;
4437     r = (i >> 7);               /* r < 10 */
4438     if (r) {
4439       *done = 0;
4440     }
4441     *(t++) = '0' + r;
4442   }
4443   *(t++) = '\0';
4444   SvCUR_set(pnum, (STRLEN) (t - s));
4445   return (m);
4446 }
4447
4448
4449 PP(pp_pack)
4450 {
4451     djSP; dMARK; dORIGMARK; dTARGET;
4452     register SV *cat = TARG;
4453     register I32 items;
4454     STRLEN fromlen;
4455     register char *pat = SvPVx(*++MARK, fromlen);
4456     char *patcopy;
4457     register char *patend = pat + fromlen;
4458     register I32 len;
4459     I32 datumtype;
4460     SV *fromstr;
4461     /*SUPPRESS 442*/
4462     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4463     static char *space10 = "          ";
4464
4465     /* These must not be in registers: */
4466     char achar;
4467     I16 ashort;
4468     int aint;
4469     unsigned int auint;
4470     I32 along;
4471     U32 aulong;
4472 #ifdef HAS_QUAD
4473     Quad_t aquad;
4474     Uquad_t auquad;
4475 #endif
4476     char *aptr;
4477     float afloat;
4478     double adouble;
4479     int commas = 0;
4480 #ifdef PERL_NATINT_PACK
4481     int natint;         /* native integer */
4482 #endif
4483
4484     items = SP - MARK;
4485     MARK++;
4486     sv_setpvn(cat, "", 0);
4487     patcopy = pat;
4488     while (pat < patend) {
4489         SV *lengthcode = Nullsv;
4490 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4491         datumtype = *pat++ & 0xFF;
4492 #ifdef PERL_NATINT_PACK
4493         natint = 0;
4494 #endif
4495         if (isSPACE(datumtype)) {
4496             patcopy++;
4497             continue;
4498         }
4499         if (datumtype == 'U' && pat == patcopy+1)
4500             SvUTF8_on(cat);
4501         if (datumtype == '#') {
4502             while (pat < patend && *pat != '\n')
4503                 pat++;
4504             continue;
4505         }
4506         if (*pat == '!') {
4507             char *natstr = "sSiIlL";
4508
4509             if (strchr(natstr, datumtype)) {
4510 #ifdef PERL_NATINT_PACK
4511                 natint = 1;
4512 #endif
4513                 pat++;
4514             }
4515             else
4516                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4517         }
4518         if (*pat == '*') {
4519             len = strchr("@Xxu", datumtype) ? 0 : items;
4520             pat++;
4521         }
4522         else if (isDIGIT(*pat)) {
4523             len = *pat++ - '0';
4524             while (isDIGIT(*pat)) {
4525                 len = (len * 10) + (*pat++ - '0');
4526                 if (len < 0)
4527                     DIE(aTHX_ "Repeat count in pack overflows");
4528             }
4529         }
4530         else
4531             len = 1;
4532         if (*pat == '/') {
4533             ++pat;
4534             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4535                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4536             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4537                                                    ? *MARK : &PL_sv_no)
4538                                             + (*pat == 'Z' ? 1 : 0)));
4539         }
4540         switch(datumtype) {
4541         default:
4542             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4543         case ',': /* grandfather in commas but with a warning */
4544             if (commas++ == 0 && ckWARN(WARN_PACK))
4545                 Perl_warner(aTHX_ WARN_PACK,
4546                             "Invalid type in pack: '%c'", (int)datumtype);
4547             break;
4548         case '%':
4549             DIE(aTHX_ "%% may only be used in unpack");
4550         case '@':
4551             len -= SvCUR(cat);
4552             if (len > 0)
4553                 goto grow;
4554             len = -len;
4555             if (len > 0)
4556                 goto shrink;
4557             break;
4558         case 'X':
4559           shrink:
4560             if (SvCUR(cat) < len)
4561                 DIE(aTHX_ "X outside of string");
4562             SvCUR(cat) -= len;
4563             *SvEND(cat) = '\0';
4564             break;
4565         case 'x':
4566           grow:
4567             while (len >= 10) {
4568                 sv_catpvn(cat, null10, 10);
4569                 len -= 10;
4570             }
4571             sv_catpvn(cat, null10, len);
4572             break;
4573         case 'A':
4574         case 'Z':
4575         case 'a':
4576             fromstr = NEXTFROM;
4577             aptr = SvPV(fromstr, fromlen);
4578             if (pat[-1] == '*') {
4579                 len = fromlen;
4580                 if (datumtype == 'Z')
4581                     ++len;
4582             }
4583             if (fromlen >= len) {
4584                 sv_catpvn(cat, aptr, len);
4585                 if (datumtype == 'Z')
4586                     *(SvEND(cat)-1) = '\0';
4587             }
4588             else {
4589                 sv_catpvn(cat, aptr, fromlen);
4590                 len -= fromlen;
4591                 if (datumtype == 'A') {
4592                     while (len >= 10) {
4593                         sv_catpvn(cat, space10, 10);
4594                         len -= 10;
4595                     }
4596                     sv_catpvn(cat, space10, len);
4597                 }
4598                 else {
4599                     while (len >= 10) {
4600                         sv_catpvn(cat, null10, 10);
4601                         len -= 10;
4602                     }
4603                     sv_catpvn(cat, null10, len);
4604                 }
4605             }
4606             break;
4607         case 'B':
4608         case 'b':
4609             {
4610                 register char *str;
4611                 I32 saveitems;
4612
4613                 fromstr = NEXTFROM;
4614                 saveitems = items;
4615                 str = SvPV(fromstr, fromlen);
4616                 if (pat[-1] == '*')
4617                     len = fromlen;
4618                 aint = SvCUR(cat);
4619                 SvCUR(cat) += (len+7)/8;
4620                 SvGROW(cat, SvCUR(cat) + 1);
4621                 aptr = SvPVX(cat) + aint;
4622                 if (len > fromlen)
4623                     len = fromlen;
4624                 aint = len;
4625                 items = 0;
4626                 if (datumtype == 'B') {
4627                     for (len = 0; len++ < aint;) {
4628                         items |= *str++ & 1;
4629                         if (len & 7)
4630                             items <<= 1;
4631                         else {
4632                             *aptr++ = items & 0xff;
4633                             items = 0;
4634                         }
4635                     }
4636                 }
4637                 else {
4638                     for (len = 0; len++ < aint;) {
4639                         if (*str++ & 1)
4640                             items |= 128;
4641                         if (len & 7)
4642                             items >>= 1;
4643                         else {
4644                             *aptr++ = items & 0xff;
4645                             items = 0;
4646                         }
4647                     }
4648                 }
4649                 if (aint & 7) {
4650                     if (datumtype == 'B')
4651                         items <<= 7 - (aint & 7);
4652                     else
4653                         items >>= 7 - (aint & 7);
4654                     *aptr++ = items & 0xff;
4655                 }
4656                 str = SvPVX(cat) + SvCUR(cat);
4657                 while (aptr <= str)
4658                     *aptr++ = '\0';
4659
4660                 items = saveitems;
4661             }
4662             break;
4663         case 'H':
4664         case 'h':
4665             {
4666                 register char *str;
4667                 I32 saveitems;
4668
4669                 fromstr = NEXTFROM;
4670                 saveitems = items;
4671                 str = SvPV(fromstr, fromlen);
4672                 if (pat[-1] == '*')
4673                     len = fromlen;
4674                 aint = SvCUR(cat);
4675                 SvCUR(cat) += (len+1)/2;
4676                 SvGROW(cat, SvCUR(cat) + 1);
4677                 aptr = SvPVX(cat) + aint;
4678                 if (len > fromlen)
4679                     len = fromlen;
4680                 aint = len;
4681                 items = 0;
4682                 if (datumtype == 'H') {
4683                     for (len = 0; len++ < aint;) {
4684                         if (isALPHA(*str))
4685                             items |= ((*str++ & 15) + 9) & 15;
4686                         else
4687                             items |= *str++ & 15;
4688                         if (len & 1)
4689                             items <<= 4;
4690                         else {
4691                             *aptr++ = items & 0xff;
4692                             items = 0;
4693                         }
4694                     }
4695                 }
4696                 else {
4697                     for (len = 0; len++ < aint;) {
4698                         if (isALPHA(*str))
4699                             items |= (((*str++ & 15) + 9) & 15) << 4;
4700                         else
4701                             items |= (*str++ & 15) << 4;
4702                         if (len & 1)
4703                             items >>= 4;
4704                         else {
4705                             *aptr++ = items & 0xff;
4706                             items = 0;
4707                         }
4708                     }
4709                 }
4710                 if (aint & 1)
4711                     *aptr++ = items & 0xff;
4712                 str = SvPVX(cat) + SvCUR(cat);
4713                 while (aptr <= str)
4714                     *aptr++ = '\0';
4715
4716                 items = saveitems;
4717             }
4718             break;
4719         case 'C':
4720         case 'c':
4721             while (len-- > 0) {
4722                 fromstr = NEXTFROM;
4723                 aint = SvIV(fromstr);
4724                 achar = aint;
4725                 sv_catpvn(cat, &achar, sizeof(char));
4726             }
4727             break;
4728         case 'U':
4729             while (len-- > 0) {
4730                 fromstr = NEXTFROM;
4731                 auint = SvUV(fromstr);
4732                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
4733                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4734                                - SvPVX(cat));
4735             }
4736             *SvEND(cat) = '\0';
4737             break;
4738         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4739         case 'f':
4740         case 'F':
4741             while (len-- > 0) {
4742                 fromstr = NEXTFROM;
4743                 afloat = (float)SvNV(fromstr);
4744                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4745             }
4746             break;
4747         case 'd':
4748         case 'D':
4749             while (len-- > 0) {
4750                 fromstr = NEXTFROM;
4751                 adouble = (double)SvNV(fromstr);
4752                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4753             }
4754             break;
4755         case 'n':
4756             while (len-- > 0) {
4757                 fromstr = NEXTFROM;
4758                 ashort = (I16)SvIV(fromstr);
4759 #ifdef HAS_HTONS
4760                 ashort = PerlSock_htons(ashort);
4761 #endif
4762                 CAT16(cat, &ashort);
4763             }
4764             break;
4765         case 'v':
4766             while (len-- > 0) {
4767                 fromstr = NEXTFROM;
4768                 ashort = (I16)SvIV(fromstr);
4769 #ifdef HAS_HTOVS
4770                 ashort = htovs(ashort);
4771 #endif
4772                 CAT16(cat, &ashort);
4773             }
4774             break;
4775         case 'S':
4776 #if SHORTSIZE != SIZE16
4777             if (natint) {
4778                 unsigned short aushort;
4779
4780                 while (len-- > 0) {
4781                     fromstr = NEXTFROM;
4782                     aushort = SvUV(fromstr);
4783                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4784                 }
4785             }
4786             else
4787 #endif
4788             {
4789                 U16 aushort;
4790
4791                 while (len-- > 0) {
4792                     fromstr = NEXTFROM;
4793                     aushort = (U16)SvUV(fromstr);
4794                     CAT16(cat, &aushort);
4795                 }
4796
4797             }
4798             break;
4799         case 's':
4800 #if SHORTSIZE != SIZE16
4801             if (natint) {
4802                 short ashort;
4803
4804                 while (len-- > 0) {
4805                     fromstr = NEXTFROM;
4806                     ashort = SvIV(fromstr);
4807                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4808                 }
4809             }
4810             else
4811 #endif
4812             {
4813                 while (len-- > 0) {
4814                     fromstr = NEXTFROM;
4815                     ashort = (I16)SvIV(fromstr);
4816                     CAT16(cat, &ashort);
4817                 }
4818             }
4819             break;
4820         case 'I':
4821             while (len-- > 0) {
4822                 fromstr = NEXTFROM;
4823                 auint = SvUV(fromstr);
4824                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4825             }
4826             break;
4827         case 'w':
4828             while (len-- > 0) {
4829                 fromstr = NEXTFROM;
4830                 adouble = Perl_floor(SvNV(fromstr));
4831
4832                 if (adouble < 0)
4833                     DIE(aTHX_ "Cannot compress negative numbers");
4834
4835                 if (
4836 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4837                     adouble <= 0xffffffff
4838 #else
4839 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
4840                     adouble <= UV_MAX_cxux
4841 #   else
4842                     adouble <= UV_MAX
4843 #   endif
4844 #endif
4845                     )
4846                 {
4847                     char   buf[1 + sizeof(UV)];
4848                     char  *in = buf + sizeof(buf);
4849                     UV     auv = U_V(adouble);
4850
4851                     do {
4852                         *--in = (auv & 0x7f) | 0x80;
4853                         auv >>= 7;
4854                     } while (auv);
4855                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4856                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4857                 }
4858                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4859                     char           *from, *result, *in;
4860                     SV             *norm;
4861                     STRLEN          len;
4862                     bool            done;
4863
4864                     /* Copy string and check for compliance */
4865                     from = SvPV(fromstr, len);
4866                     if ((norm = is_an_int(from, len)) == NULL)
4867                         DIE(aTHX_ "can compress only unsigned integer");
4868
4869                     New('w', result, len, char);
4870                     in = result + len;
4871                     done = FALSE;
4872                     while (!done)
4873                         *--in = div128(norm, &done) | 0x80;
4874                     result[len - 1] &= 0x7F; /* clear continue bit */
4875                     sv_catpvn(cat, in, (result + len) - in);
4876                     Safefree(result);
4877                     SvREFCNT_dec(norm); /* free norm */
4878                 }
4879                 else if (SvNOKp(fromstr)) {
4880                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4881                     char  *in = buf + sizeof(buf);
4882
4883                     do {
4884                         double next = floor(adouble / 128);
4885                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4886                         if (in <= buf)  /* this cannot happen ;-) */
4887                             DIE(aTHX_ "Cannot compress integer");
4888                         in--;
4889                         adouble = next;
4890                     } while (adouble > 0);
4891                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4892                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4893                 }
4894                 else
4895                     DIE(aTHX_ "Cannot compress non integer");
4896             }
4897             break;
4898         case 'i':
4899             while (len-- > 0) {
4900                 fromstr = NEXTFROM;
4901                 aint = SvIV(fromstr);
4902                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4903             }
4904             break;
4905         case 'N':
4906             while (len-- > 0) {
4907                 fromstr = NEXTFROM;
4908                 aulong = SvUV(fromstr);
4909 #ifdef HAS_HTONL
4910                 aulong = PerlSock_htonl(aulong);
4911 #endif
4912                 CAT32(cat, &aulong);
4913             }
4914             break;
4915         case 'V':
4916             while (len-- > 0) {
4917                 fromstr = NEXTFROM;
4918                 aulong = SvUV(fromstr);
4919 #ifdef HAS_HTOVL
4920                 aulong = htovl(aulong);
4921 #endif
4922                 CAT32(cat, &aulong);
4923             }
4924             break;
4925         case 'L':
4926 #if LONGSIZE != SIZE32
4927             if (natint) {
4928                 unsigned long aulong;
4929
4930                 while (len-- > 0) {
4931                     fromstr = NEXTFROM;
4932                     aulong = SvUV(fromstr);
4933                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4934                 }
4935             }
4936             else
4937 #endif
4938             {
4939                 while (len-- > 0) {
4940                     fromstr = NEXTFROM;
4941                     aulong = SvUV(fromstr);
4942                     CAT32(cat, &aulong);
4943                 }
4944             }
4945             break;
4946         case 'l':
4947 #if LONGSIZE != SIZE32
4948             if (natint) {
4949                 long along;
4950
4951                 while (len-- > 0) {
4952                     fromstr = NEXTFROM;
4953                     along = SvIV(fromstr);
4954                     sv_catpvn(cat, (char *)&along, sizeof(long));
4955                 }
4956             }
4957             else
4958 #endif
4959             {
4960                 while (len-- > 0) {
4961                     fromstr = NEXTFROM;
4962                     along = SvIV(fromstr);
4963                     CAT32(cat, &along);
4964                 }
4965             }
4966             break;
4967 #ifdef HAS_QUAD
4968         case 'Q':
4969             while (len-- > 0) {
4970                 fromstr = NEXTFROM;
4971                 auquad = (Uquad_t)SvUV(fromstr);
4972                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4973             }
4974             break;
4975         case 'q':
4976             while (len-- > 0) {
4977                 fromstr = NEXTFROM;
4978                 aquad = (Quad_t)SvIV(fromstr);
4979                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4980             }
4981             break;
4982 #endif
4983         case 'P':
4984             len = 1;            /* assume SV is correct length */
4985             /* FALL THROUGH */
4986         case 'p':
4987             while (len-- > 0) {
4988                 fromstr = NEXTFROM;
4989                 if (fromstr == &PL_sv_undef)
4990                     aptr = NULL;
4991                 else {
4992                     STRLEN n_a;
4993                     /* XXX better yet, could spirit away the string to
4994                      * a safe spot and hang on to it until the result
4995                      * of pack() (and all copies of the result) are
4996                      * gone.
4997                      */
4998                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4999                                                 || (SvPADTMP(fromstr)
5000                                                     && !SvREADONLY(fromstr))))
5001                     {
5002                         Perl_warner(aTHX_ WARN_PACK,
5003                                 "Attempt to pack pointer to temporary value");
5004                     }
5005                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5006                         aptr = SvPV(fromstr,n_a);
5007                     else
5008                         aptr = SvPV_force(fromstr,n_a);
5009                 }
5010                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5011             }
5012             break;
5013         case 'u':
5014             fromstr = NEXTFROM;
5015             aptr = SvPV(fromstr, fromlen);
5016             SvGROW(cat, fromlen * 4 / 3);
5017             if (len <= 1)
5018                 len = 45;
5019             else
5020                 len = len / 3 * 3;
5021             while (fromlen > 0) {
5022                 I32 todo;
5023
5024                 if (fromlen > len)
5025                     todo = len;
5026                 else
5027                     todo = fromlen;
5028                 doencodes(cat, aptr, todo);
5029                 fromlen -= todo;
5030                 aptr += todo;
5031             }
5032             break;
5033         }
5034     }
5035     SvSETMAGIC(cat);
5036     SP = ORIGMARK;
5037     PUSHs(cat);
5038     RETURN;
5039 }
5040 #undef NEXTFROM
5041
5042
5043 PP(pp_split)
5044 {
5045     djSP; dTARG;
5046     AV *ary;
5047     register IV limit = POPi;                   /* note, negative is forever */
5048     SV *sv = POPs;
5049     bool doutf8 = DO_UTF8(sv);
5050     STRLEN len;
5051     register char *s = SvPV(sv, len);
5052     char *strend = s + len;
5053     register PMOP *pm;
5054     register REGEXP *rx;
5055     register SV *dstr;
5056     register char *m;
5057     I32 iters = 0;
5058     I32 maxiters = (strend - s) + 10;
5059     I32 i;
5060     char *orig;
5061     I32 origlimit = limit;
5062     I32 realarray = 0;
5063     I32 base;
5064     AV *oldstack = PL_curstack;
5065     I32 gimme = GIMME_V;
5066     I32 oldsave = PL_savestack_ix;
5067     I32 make_mortal = 1;
5068     MAGIC *mg = (MAGIC *) NULL;
5069
5070 #ifdef DEBUGGING
5071     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5072 #else
5073     pm = (PMOP*)POPs;
5074 #endif
5075     if (!pm || !s)
5076         DIE(aTHX_ "panic: do_split");
5077     rx = pm->op_pmregexp;
5078
5079     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5080              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5081
5082     if (pm->op_pmreplroot) {
5083 #ifdef USE_ITHREADS
5084         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5085 #else
5086         ary = GvAVn((GV*)pm->op_pmreplroot);
5087 #endif
5088     }
5089     else if (gimme != G_ARRAY)
5090 #ifdef USE_THREADS
5091         ary = (AV*)PL_curpad[0];
5092 #else
5093         ary = GvAVn(PL_defgv);
5094 #endif /* USE_THREADS */
5095     else
5096         ary = Nullav;
5097     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5098         realarray = 1;
5099         PUTBACK;
5100         av_extend(ary,0);
5101         av_clear(ary);
5102         SPAGAIN;
5103         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5104             PUSHMARK(SP);
5105             XPUSHs(SvTIED_obj((SV*)ary, mg));
5106         }
5107         else {
5108             if (!AvREAL(ary)) {
5109                 AvREAL_on(ary);
5110                 AvREIFY_off(ary);
5111                 for (i = AvFILLp(ary); i >= 0; i--)
5112                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5113             }
5114             /* temporarily switch stacks */
5115             SWITCHSTACK(PL_curstack, ary);
5116             make_mortal = 0;
5117         }
5118     }
5119     base = SP - PL_stack_base;
5120     orig = s;
5121     if (pm->op_pmflags & PMf_SKIPWHITE) {
5122         if (pm->op_pmflags & PMf_LOCALE) {
5123             while (isSPACE_LC(*s))
5124                 s++;
5125         }
5126         else {
5127             while (isSPACE(*s))
5128                 s++;
5129         }
5130     }
5131     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5132         SAVEINT(PL_multiline);
5133         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5134     }
5135
5136     if (!limit)
5137         limit = maxiters + 2;
5138     if (pm->op_pmflags & PMf_WHITE) {
5139         while (--limit) {
5140             m = s;
5141             while (m < strend &&
5142                    !((pm->op_pmflags & PMf_LOCALE)
5143                      ? isSPACE_LC(*m) : isSPACE(*m)))
5144                 ++m;
5145             if (m >= strend)
5146                 break;
5147
5148             dstr = NEWSV(30, m-s);
5149             sv_setpvn(dstr, s, m-s);
5150             if (make_mortal)
5151                 sv_2mortal(dstr);
5152             if (doutf8)
5153                 (void)SvUTF8_on(dstr);
5154             XPUSHs(dstr);
5155
5156             s = m + 1;
5157             while (s < strend &&
5158                    ((pm->op_pmflags & PMf_LOCALE)
5159                     ? isSPACE_LC(*s) : isSPACE(*s)))
5160                 ++s;
5161         }
5162     }
5163     else if (strEQ("^", rx->precomp)) {
5164         while (--limit) {
5165             /*SUPPRESS 530*/
5166             for (m = s; m < strend && *m != '\n'; m++) ;
5167             m++;
5168             if (m >= strend)
5169                 break;
5170             dstr = NEWSV(30, m-s);
5171             sv_setpvn(dstr, s, m-s);
5172             if (make_mortal)
5173                 sv_2mortal(dstr);
5174             if (doutf8)
5175                 (void)SvUTF8_on(dstr);
5176             XPUSHs(dstr);
5177             s = m;
5178         }
5179     }
5180     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5181              && (rx->reganch & ROPT_CHECK_ALL)
5182              && !(rx->reganch & ROPT_ANCH)) {
5183         int tail = (rx->reganch & RE_INTUIT_TAIL);
5184         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5185
5186         len = rx->minlen;
5187         if (len == 1 && !tail) {
5188             STRLEN n_a;
5189             char c = *SvPV(csv, n_a);
5190             while (--limit) {
5191                 /*SUPPRESS 530*/
5192                 for (m = s; m < strend && *m != c; m++) ;
5193                 if (m >= strend)
5194                     break;
5195                 dstr = NEWSV(30, m-s);
5196                 sv_setpvn(dstr, s, m-s);
5197                 if (make_mortal)
5198                     sv_2mortal(dstr);
5199                 if (doutf8)
5200                     (void)SvUTF8_on(dstr);
5201                 XPUSHs(dstr);
5202                 /* The rx->minlen is in characters but we want to step
5203                  * s ahead by bytes. */
5204                 s = m + (doutf8 ? SvCUR(csv) : len);
5205             }
5206         }
5207         else {
5208 #ifndef lint
5209             while (s < strend && --limit &&
5210               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5211                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5212 #endif
5213             {
5214                 dstr = NEWSV(31, m-s);
5215                 sv_setpvn(dstr, s, m-s);
5216                 if (make_mortal)
5217                     sv_2mortal(dstr);
5218                 if (doutf8)
5219                     (void)SvUTF8_on(dstr);
5220                 XPUSHs(dstr);
5221                 /* The rx->minlen is in characters but we want to step
5222                  * s ahead by bytes. */
5223                 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5224             }
5225         }
5226     }
5227     else {
5228         maxiters += (strend - s) * rx->nparens;
5229         while (s < strend && --limit
5230 /*             && (!rx->check_substr
5231                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5232                                                  0, NULL))))
5233 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5234                               1 /* minend */, sv, NULL, 0))
5235         {
5236             TAINT_IF(RX_MATCH_TAINTED(rx));
5237             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5238                 m = s;
5239                 s = orig;
5240                 orig = rx->subbeg;
5241                 s = orig + (m - s);
5242                 strend = s + (strend - m);
5243             }
5244             m = rx->startp[0] + orig;
5245             dstr = NEWSV(32, m-s);
5246             sv_setpvn(dstr, s, m-s);
5247             if (make_mortal)
5248                 sv_2mortal(dstr);
5249             if (doutf8)
5250                 (void)SvUTF8_on(dstr);
5251             XPUSHs(dstr);
5252             if (rx->nparens) {
5253                 for (i = 1; i <= rx->nparens; i++) {
5254                     s = rx->startp[i] + orig;
5255                     m = rx->endp[i] + orig;
5256                     if (m && s) {
5257                         dstr = NEWSV(33, m-s);
5258                         sv_setpvn(dstr, s, m-s);
5259                     }
5260                     else
5261                         dstr = NEWSV(33, 0);
5262                     if (make_mortal)
5263                         sv_2mortal(dstr);
5264                     if (doutf8)
5265                         (void)SvUTF8_on(dstr);
5266                     XPUSHs(dstr);
5267                 }
5268             }
5269             s = rx->endp[0] + orig;
5270         }
5271     }
5272
5273     LEAVE_SCOPE(oldsave);
5274     iters = (SP - PL_stack_base) - base;
5275     if (iters > maxiters)
5276         DIE(aTHX_ "Split loop");
5277
5278     /* keep field after final delim? */
5279     if (s < strend || (iters && origlimit)) {
5280         STRLEN l = strend - s;
5281         dstr = NEWSV(34, l);
5282         sv_setpvn(dstr, s, l);
5283         if (make_mortal)
5284             sv_2mortal(dstr);
5285         if (doutf8)
5286             (void)SvUTF8_on(dstr);
5287         XPUSHs(dstr);
5288         iters++;
5289     }
5290     else if (!origlimit) {
5291         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5292             iters--, SP--;
5293     }
5294
5295     if (realarray) {
5296         if (!mg) {
5297             SWITCHSTACK(ary, oldstack);
5298             if (SvSMAGICAL(ary)) {
5299                 PUTBACK;
5300                 mg_set((SV*)ary);
5301                 SPAGAIN;
5302             }
5303             if (gimme == G_ARRAY) {
5304                 EXTEND(SP, iters);
5305                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5306                 SP += iters;
5307                 RETURN;
5308             }
5309         }
5310         else {
5311             PUTBACK;
5312             ENTER;
5313             call_method("PUSH",G_SCALAR|G_DISCARD);
5314             LEAVE;
5315             SPAGAIN;
5316             if (gimme == G_ARRAY) {
5317                 /* EXTEND should not be needed - we just popped them */
5318                 EXTEND(SP, iters);
5319                 for (i=0; i < iters; i++) {
5320                     SV **svp = av_fetch(ary, i, FALSE);
5321                     PUSHs((svp) ? *svp : &PL_sv_undef);
5322                 }
5323                 RETURN;
5324             }
5325         }
5326     }
5327     else {
5328         if (gimme == G_ARRAY)
5329             RETURN;
5330     }
5331     if (iters || !pm->op_pmreplroot) {
5332         GETTARGET;
5333         PUSHi(iters);
5334         RETURN;
5335     }
5336     RETPUSHUNDEF;
5337 }
5338
5339 #ifdef USE_THREADS
5340 void
5341 Perl_unlock_condpair(pTHX_ void *svv)
5342 {
5343     dTHR;
5344     MAGIC *mg = mg_find((SV*)svv, 'm');
5345
5346     if (!mg)
5347         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5348     MUTEX_LOCK(MgMUTEXP(mg));
5349     if (MgOWNER(mg) != thr)
5350         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5351     MgOWNER(mg) = 0;
5352     COND_SIGNAL(MgOWNERCONDP(mg));
5353     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5354                           PTR2UV(thr), PTR2UV(svv));)
5355     MUTEX_UNLOCK(MgMUTEXP(mg));
5356 }
5357 #endif /* USE_THREADS */
5358
5359 PP(pp_lock)
5360 {
5361     djSP;
5362     dTOPss;
5363     SV *retsv = sv;
5364 #ifdef USE_THREADS
5365     sv_lock(sv);
5366 #endif /* USE_THREADS */
5367     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5368         || SvTYPE(retsv) == SVt_PVCV) {
5369         retsv = refto(retsv);
5370     }
5371     SETs(retsv);
5372     RETURN;
5373 }
5374
5375 PP(pp_threadsv)
5376 {
5377 #ifdef USE_THREADS
5378     djSP;
5379     EXTEND(SP, 1);
5380     if (PL_op->op_private & OPpLVAL_INTRO)
5381         PUSHs(*save_threadsv(PL_op->op_targ));
5382     else
5383         PUSHs(THREADSV(PL_op->op_targ));
5384     RETURN;
5385 #else
5386     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5387 #endif /* USE_THREADS */
5388 }