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];
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];
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 (gimme == G_ARRAY) {
2697             SV *val;
2698             PUTBACK;
2699             /* might clobber stack_sp */
2700             val = realhv ?
2701                   hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2702             SPAGAIN;
2703             PUSHs(val);
2704         }
2705     }
2706     else if (gimme == G_SCALAR)
2707         RETPUSHUNDEF;
2708
2709     RETURN;
2710 }
2711
2712 PP(pp_values)
2713 {
2714     return do_kv();
2715 }
2716
2717 PP(pp_keys)
2718 {
2719     return do_kv();
2720 }
2721
2722 PP(pp_delete)
2723 {
2724     djSP;
2725     I32 gimme = GIMME_V;
2726     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2727     SV *sv;
2728     HV *hv;
2729
2730     if (PL_op->op_private & OPpSLICE) {
2731         dMARK; dORIGMARK;
2732         U32 hvtype;
2733         hv = (HV*)POPs;
2734         hvtype = SvTYPE(hv);
2735         if (hvtype == SVt_PVHV) {                       /* hash element */
2736             while (++MARK <= SP) {
2737                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2738                 *MARK = sv ? sv : &PL_sv_undef;
2739             }
2740         }
2741         else if (hvtype == SVt_PVAV) {
2742             if (PL_op->op_flags & OPf_SPECIAL) {        /* array element */
2743                 while (++MARK <= SP) {
2744                     sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2745                     *MARK = sv ? sv : &PL_sv_undef;
2746                 }
2747             }
2748             else {                                      /* pseudo-hash element */
2749                 while (++MARK <= SP) {
2750                     sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2751                     *MARK = sv ? sv : &PL_sv_undef;
2752                 }
2753             }
2754         }
2755         else
2756             DIE(aTHX_ "Not a HASH reference");
2757         if (discard)
2758             SP = ORIGMARK;
2759         else if (gimme == G_SCALAR) {
2760             MARK = ORIGMARK;
2761             *++MARK = *SP;
2762             SP = MARK;
2763         }
2764     }
2765     else {
2766         SV *keysv = POPs;
2767         hv = (HV*)POPs;
2768         if (SvTYPE(hv) == SVt_PVHV)
2769             sv = hv_delete_ent(hv, keysv, discard, 0);
2770         else if (SvTYPE(hv) == SVt_PVAV) {
2771             if (PL_op->op_flags & OPf_SPECIAL)
2772                 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2773             else
2774                 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2775         }
2776         else
2777             DIE(aTHX_ "Not a HASH reference");
2778         if (!sv)
2779             sv = &PL_sv_undef;
2780         if (!discard)
2781             PUSHs(sv);
2782     }
2783     RETURN;
2784 }
2785
2786 PP(pp_exists)
2787 {
2788     djSP;
2789     SV *tmpsv;
2790     HV *hv;
2791
2792     if (PL_op->op_private & OPpEXISTS_SUB) {
2793         GV *gv;
2794         CV *cv;
2795         SV *sv = POPs;
2796         cv = sv_2cv(sv, &hv, &gv, FALSE);
2797         if (cv)
2798             RETPUSHYES;
2799         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2800             RETPUSHYES;
2801         RETPUSHNO;
2802     }
2803     tmpsv = POPs;
2804     hv = (HV*)POPs;
2805     if (SvTYPE(hv) == SVt_PVHV) {
2806         if (hv_exists_ent(hv, tmpsv, 0))
2807             RETPUSHYES;
2808     }
2809     else if (SvTYPE(hv) == SVt_PVAV) {
2810         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
2811             if (av_exists((AV*)hv, SvIV(tmpsv)))
2812                 RETPUSHYES;
2813         }
2814         else if (avhv_exists_ent((AV*)hv, tmpsv, 0))    /* pseudo-hash element */
2815             RETPUSHYES;
2816     }
2817     else {
2818         DIE(aTHX_ "Not a HASH reference");
2819     }
2820     RETPUSHNO;
2821 }
2822
2823 PP(pp_hslice)
2824 {
2825     djSP; dMARK; dORIGMARK;
2826     register HV *hv = (HV*)POPs;
2827     register I32 lval = PL_op->op_flags & OPf_MOD;
2828     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2829
2830     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2831         DIE(aTHX_ "Can't localize pseudo-hash element");
2832
2833     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2834         while (++MARK <= SP) {
2835             SV *keysv = *MARK;
2836             SV **svp;
2837             if (realhv) {
2838                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2839                 svp = he ? &HeVAL(he) : 0;
2840             }
2841             else {
2842                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2843             }
2844             if (lval) {
2845                 if (!svp || *svp == &PL_sv_undef) {
2846                     STRLEN n_a;
2847                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2848                 }
2849                 if (PL_op->op_private & OPpLVAL_INTRO)
2850                     save_helem(hv, keysv, svp);
2851             }
2852             *MARK = svp ? *svp : &PL_sv_undef;
2853         }
2854     }
2855     if (GIMME != G_ARRAY) {
2856         MARK = ORIGMARK;
2857         *++MARK = *SP;
2858         SP = MARK;
2859     }
2860     RETURN;
2861 }
2862
2863 /* List operators. */
2864
2865 PP(pp_list)
2866 {
2867     djSP; dMARK;
2868     if (GIMME != G_ARRAY) {
2869         if (++MARK <= SP)
2870             *MARK = *SP;                /* unwanted list, return last item */
2871         else
2872             *MARK = &PL_sv_undef;
2873         SP = MARK;
2874     }
2875     RETURN;
2876 }
2877
2878 PP(pp_lslice)
2879 {
2880     djSP;
2881     SV **lastrelem = PL_stack_sp;
2882     SV **lastlelem = PL_stack_base + POPMARK;
2883     SV **firstlelem = PL_stack_base + POPMARK + 1;
2884     register SV **firstrelem = lastlelem + 1;
2885     I32 arybase = PL_curcop->cop_arybase;
2886     I32 lval = PL_op->op_flags & OPf_MOD;
2887     I32 is_something_there = lval;
2888
2889     register I32 max = lastrelem - lastlelem;
2890     register SV **lelem;
2891     register I32 ix;
2892
2893     if (GIMME != G_ARRAY) {
2894         ix = SvIVx(*lastlelem);
2895         if (ix < 0)
2896             ix += max;
2897         else
2898             ix -= arybase;
2899         if (ix < 0 || ix >= max)
2900             *firstlelem = &PL_sv_undef;
2901         else
2902             *firstlelem = firstrelem[ix];
2903         SP = firstlelem;
2904         RETURN;
2905     }
2906
2907     if (max == 0) {
2908         SP = firstlelem - 1;
2909         RETURN;
2910     }
2911
2912     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2913         ix = SvIVx(*lelem);
2914         if (ix < 0)
2915             ix += max;
2916         else
2917             ix -= arybase;
2918         if (ix < 0 || ix >= max)
2919             *lelem = &PL_sv_undef;
2920         else {
2921             is_something_there = TRUE;
2922             if (!(*lelem = firstrelem[ix]))
2923                 *lelem = &PL_sv_undef;
2924         }
2925     }
2926     if (is_something_there)
2927         SP = lastlelem;
2928     else
2929         SP = firstlelem - 1;
2930     RETURN;
2931 }
2932
2933 PP(pp_anonlist)
2934 {
2935     djSP; dMARK; dORIGMARK;
2936     I32 items = SP - MARK;
2937     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2938     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2939     XPUSHs(av);
2940     RETURN;
2941 }
2942
2943 PP(pp_anonhash)
2944 {
2945     djSP; dMARK; dORIGMARK;
2946     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2947
2948     while (MARK < SP) {
2949         SV* key = *++MARK;
2950         SV *val = NEWSV(46, 0);
2951         if (MARK < SP)
2952             sv_setsv(val, *++MARK);
2953         else if (ckWARN(WARN_MISC))
2954             Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2955         (void)hv_store_ent(hv,key,val,0);
2956     }
2957     SP = ORIGMARK;
2958     XPUSHs((SV*)hv);
2959     RETURN;
2960 }
2961
2962 PP(pp_splice)
2963 {
2964     djSP; dMARK; dORIGMARK;
2965     register AV *ary = (AV*)*++MARK;
2966     register SV **src;
2967     register SV **dst;
2968     register I32 i;
2969     register I32 offset;
2970     register I32 length;
2971     I32 newlen;
2972     I32 after;
2973     I32 diff;
2974     SV **tmparyval = 0;
2975     MAGIC *mg;
2976
2977     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2978         *MARK-- = SvTIED_obj((SV*)ary, mg);
2979         PUSHMARK(MARK);
2980         PUTBACK;
2981         ENTER;
2982         call_method("SPLICE",GIMME_V);
2983         LEAVE;
2984         SPAGAIN;
2985         RETURN;
2986     }
2987
2988     SP++;
2989
2990     if (++MARK < SP) {
2991         offset = i = SvIVx(*MARK);
2992         if (offset < 0)
2993             offset += AvFILLp(ary) + 1;
2994         else
2995             offset -= PL_curcop->cop_arybase;
2996         if (offset < 0)
2997             DIE(aTHX_ PL_no_aelem, i);
2998         if (++MARK < SP) {
2999             length = SvIVx(*MARK++);
3000             if (length < 0) {
3001                 length += AvFILLp(ary) - offset + 1;
3002                 if (length < 0)
3003                     length = 0;
3004             }
3005         }
3006         else
3007             length = AvMAX(ary) + 1;            /* close enough to infinity */
3008     }
3009     else {
3010         offset = 0;
3011         length = AvMAX(ary) + 1;
3012     }
3013     if (offset > AvFILLp(ary) + 1)
3014         offset = AvFILLp(ary) + 1;
3015     after = AvFILLp(ary) + 1 - (offset + length);
3016     if (after < 0) {                            /* not that much array */
3017         length += after;                        /* offset+length now in array */
3018         after = 0;
3019         if (!AvALLOC(ary))
3020             av_extend(ary, 0);
3021     }
3022
3023     /* At this point, MARK .. SP-1 is our new LIST */
3024
3025     newlen = SP - MARK;
3026     diff = newlen - length;
3027     if (newlen && !AvREAL(ary) && AvREIFY(ary))
3028         av_reify(ary);
3029
3030     if (diff < 0) {                             /* shrinking the area */
3031         if (newlen) {
3032             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
3033             Copy(MARK, tmparyval, newlen, SV*);
3034         }
3035
3036         MARK = ORIGMARK + 1;
3037         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3038             MEXTEND(MARK, length);
3039             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3040             if (AvREAL(ary)) {
3041                 EXTEND_MORTAL(length);
3042                 for (i = length, dst = MARK; i; i--) {
3043                     sv_2mortal(*dst);   /* free them eventualy */
3044                     dst++;
3045                 }
3046             }
3047             MARK += length - 1;
3048         }
3049         else {
3050             *MARK = AvARRAY(ary)[offset+length-1];
3051             if (AvREAL(ary)) {
3052                 sv_2mortal(*MARK);
3053                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3054                     SvREFCNT_dec(*dst++);       /* free them now */
3055             }
3056         }
3057         AvFILLp(ary) += diff;
3058
3059         /* pull up or down? */
3060
3061         if (offset < after) {                   /* easier to pull up */
3062             if (offset) {                       /* esp. if nothing to pull */
3063                 src = &AvARRAY(ary)[offset-1];
3064                 dst = src - diff;               /* diff is negative */
3065                 for (i = offset; i > 0; i--)    /* can't trust Copy */
3066                     *dst-- = *src--;
3067             }
3068             dst = AvARRAY(ary);
3069             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3070             AvMAX(ary) += diff;
3071         }
3072         else {
3073             if (after) {                        /* anything to pull down? */
3074                 src = AvARRAY(ary) + offset + length;
3075                 dst = src + diff;               /* diff is negative */
3076                 Move(src, dst, after, SV*);
3077             }
3078             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3079                                                 /* avoid later double free */
3080         }
3081         i = -diff;
3082         while (i)
3083             dst[--i] = &PL_sv_undef;
3084
3085         if (newlen) {
3086             for (src = tmparyval, dst = AvARRAY(ary) + offset;
3087               newlen; newlen--) {
3088                 *dst = NEWSV(46, 0);
3089                 sv_setsv(*dst++, *src++);
3090             }
3091             Safefree(tmparyval);
3092         }
3093     }
3094     else {                                      /* no, expanding (or same) */
3095         if (length) {
3096             New(452, tmparyval, length, SV*);   /* so remember deletion */
3097             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3098         }
3099
3100         if (diff > 0) {                         /* expanding */
3101
3102             /* push up or down? */
3103
3104             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3105                 if (offset) {
3106                     src = AvARRAY(ary);
3107                     dst = src - diff;
3108                     Move(src, dst, offset, SV*);
3109                 }
3110                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3111                 AvMAX(ary) += diff;
3112                 AvFILLp(ary) += diff;
3113             }
3114             else {
3115                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
3116                     av_extend(ary, AvFILLp(ary) + diff);
3117                 AvFILLp(ary) += diff;
3118
3119                 if (after) {
3120                     dst = AvARRAY(ary) + AvFILLp(ary);
3121                     src = dst - diff;
3122                     for (i = after; i; i--) {
3123                         *dst-- = *src--;
3124                     }
3125                 }
3126             }
3127         }
3128
3129         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3130             *dst = NEWSV(46, 0);
3131             sv_setsv(*dst++, *src++);
3132         }
3133         MARK = ORIGMARK + 1;
3134         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3135             if (length) {
3136                 Copy(tmparyval, MARK, length, SV*);
3137                 if (AvREAL(ary)) {
3138                     EXTEND_MORTAL(length);
3139                     for (i = length, dst = MARK; i; i--) {
3140                         sv_2mortal(*dst);       /* free them eventualy */
3141                         dst++;
3142                     }
3143                 }
3144                 Safefree(tmparyval);
3145             }
3146             MARK += length - 1;
3147         }
3148         else if (length--) {
3149             *MARK = tmparyval[length];
3150             if (AvREAL(ary)) {
3151                 sv_2mortal(*MARK);
3152                 while (length-- > 0)
3153                     SvREFCNT_dec(tmparyval[length]);
3154             }
3155             Safefree(tmparyval);
3156         }
3157         else
3158             *MARK = &PL_sv_undef;
3159     }
3160     SP = MARK;
3161     RETURN;
3162 }
3163
3164 PP(pp_push)
3165 {
3166     djSP; dMARK; dORIGMARK; dTARGET;
3167     register AV *ary = (AV*)*++MARK;
3168     register SV *sv = &PL_sv_undef;
3169     MAGIC *mg;
3170
3171     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3172         *MARK-- = SvTIED_obj((SV*)ary, mg);
3173         PUSHMARK(MARK);
3174         PUTBACK;
3175         ENTER;
3176         call_method("PUSH",G_SCALAR|G_DISCARD);
3177         LEAVE;
3178         SPAGAIN;
3179     }
3180     else {
3181         /* Why no pre-extend of ary here ? */
3182         for (++MARK; MARK <= SP; MARK++) {
3183             sv = NEWSV(51, 0);
3184             if (*MARK)
3185                 sv_setsv(sv, *MARK);
3186             av_push(ary, sv);
3187         }
3188     }
3189     SP = ORIGMARK;
3190     PUSHi( AvFILL(ary) + 1 );
3191     RETURN;
3192 }
3193
3194 PP(pp_pop)
3195 {
3196     djSP;
3197     AV *av = (AV*)POPs;
3198     SV *sv = av_pop(av);
3199     if (AvREAL(av))
3200         (void)sv_2mortal(sv);
3201     PUSHs(sv);
3202     RETURN;
3203 }
3204
3205 PP(pp_shift)
3206 {
3207     djSP;
3208     AV *av = (AV*)POPs;
3209     SV *sv = av_shift(av);
3210     EXTEND(SP, 1);
3211     if (!sv)
3212         RETPUSHUNDEF;
3213     if (AvREAL(av))
3214         (void)sv_2mortal(sv);
3215     PUSHs(sv);
3216     RETURN;
3217 }
3218
3219 PP(pp_unshift)
3220 {
3221     djSP; dMARK; dORIGMARK; dTARGET;
3222     register AV *ary = (AV*)*++MARK;
3223     register SV *sv;
3224     register I32 i = 0;
3225     MAGIC *mg;
3226
3227     if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3228         *MARK-- = SvTIED_obj((SV*)ary, mg);
3229         PUSHMARK(MARK);
3230         PUTBACK;
3231         ENTER;
3232         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3233         LEAVE;
3234         SPAGAIN;
3235     }
3236     else {
3237         av_unshift(ary, SP - MARK);
3238         while (MARK < SP) {
3239             sv = NEWSV(27, 0);
3240             sv_setsv(sv, *++MARK);
3241             (void)av_store(ary, i++, sv);
3242         }
3243     }
3244     SP = ORIGMARK;
3245     PUSHi( AvFILL(ary) + 1 );
3246     RETURN;
3247 }
3248
3249 PP(pp_reverse)
3250 {
3251     djSP; dMARK;
3252     register SV *tmp;
3253     SV **oldsp = SP;
3254
3255     if (GIMME == G_ARRAY) {
3256         MARK++;
3257         while (MARK < SP) {
3258             tmp = *MARK;
3259             *MARK++ = *SP;
3260             *SP-- = tmp;
3261         }
3262         /* safe as long as stack cannot get extended in the above */
3263         SP = oldsp;
3264     }
3265     else {
3266         register char *up;
3267         register char *down;
3268         register I32 tmp;
3269         dTARGET;
3270         STRLEN len;
3271
3272         SvUTF8_off(TARG);                               /* decontaminate */
3273         if (SP - MARK > 1)
3274             do_join(TARG, &PL_sv_no, MARK, SP);
3275         else
3276             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3277         up = SvPV_force(TARG, len);
3278         if (len > 1) {
3279             if (DO_UTF8(TARG)) {        /* first reverse each character */
3280                 U8* s = (U8*)SvPVX(TARG);
3281                 U8* send = (U8*)(s + len);
3282                 while (s < send) {
3283                     if (*s < 0x80) {
3284                         s++;
3285                         continue;
3286                     }
3287                     else {
3288                         up = (char*)s;
3289                         s += UTF8SKIP(s);
3290                         down = (char*)(s - 1);
3291                         if (s > send || !((*down & 0xc0) == 0x80)) {
3292                             if (ckWARN_d(WARN_UTF8))
3293                                 Perl_warner(aTHX_ WARN_UTF8,
3294                                             "Malformed UTF-8 character");
3295                             break;
3296                         }
3297                         while (down > up) {
3298                             tmp = *up;
3299                             *up++ = *down;
3300                             *down-- = tmp;
3301                         }
3302                     }
3303                 }
3304                 up = SvPVX(TARG);
3305             }
3306             down = SvPVX(TARG) + len - 1;
3307             while (down > up) {
3308                 tmp = *up;
3309                 *up++ = *down;
3310                 *down-- = tmp;
3311             }
3312             (void)SvPOK_only_UTF8(TARG);
3313         }
3314         SP = MARK + 1;
3315         SETTARG;
3316     }
3317     RETURN;
3318 }
3319
3320 STATIC SV *
3321 S_mul128(pTHX_ SV *sv, U8 m)
3322 {
3323   STRLEN          len;
3324   char           *s = SvPV(sv, len);
3325   char           *t;
3326   U32             i = 0;
3327
3328   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3329     SV             *tmpNew = newSVpvn("0000000000", 10);
3330
3331     sv_catsv(tmpNew, sv);
3332     SvREFCNT_dec(sv);           /* free old sv */
3333     sv = tmpNew;
3334     s = SvPV(sv, len);
3335   }
3336   t = s + len - 1;
3337   while (!*t)                   /* trailing '\0'? */
3338     t--;
3339   while (t > s) {
3340     i = ((*t - '0') << 7) + m;
3341     *(t--) = '0' + (i % 10);
3342     m = i / 10;
3343   }
3344   return (sv);
3345 }
3346
3347 /* Explosives and implosives. */
3348
3349 #if 'I' == 73 && 'J' == 74
3350 /* On an ASCII/ISO kind of system */
3351 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3352 #else
3353 /*
3354   Some other sort of character set - use memchr() so we don't match
3355   the null byte.
3356  */
3357 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3358 #endif
3359
3360 PP(pp_unpack)
3361 {
3362     djSP;
3363     dPOPPOPssrl;
3364     I32 start_sp_offset = SP - PL_stack_base;
3365     I32 gimme = GIMME_V;
3366     SV *sv;
3367     STRLEN llen;
3368     STRLEN rlen;
3369     register char *pat = SvPV(left, llen);
3370     register char *s = SvPV(right, rlen);
3371     char *strend = s + rlen;
3372     char *strbeg = s;
3373     register char *patend = pat + llen;
3374     I32 datumtype;
3375     register I32 len;
3376     register I32 bits;
3377     register char *str;
3378
3379     /* These must not be in registers: */
3380     short ashort;
3381     int aint;
3382     long along;
3383 #ifdef HAS_QUAD
3384     Quad_t aquad;
3385 #endif
3386     U16 aushort;
3387     unsigned int auint;
3388     U32 aulong;
3389 #ifdef HAS_QUAD
3390     Uquad_t auquad;
3391 #endif
3392     char *aptr;
3393     float afloat;
3394     double adouble;
3395     I32 checksum = 0;
3396     register U32 culong;
3397     NV cdouble;
3398     int commas = 0;
3399     int star;
3400 #ifdef PERL_NATINT_PACK
3401     int natint;         /* native integer */
3402     int unatint;        /* unsigned native integer */
3403 #endif
3404
3405     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3406         /*SUPPRESS 530*/
3407         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3408         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3409             patend++;
3410             while (isDIGIT(*patend) || *patend == '*')
3411                 patend++;
3412         }
3413         else
3414             patend++;
3415     }
3416     while (pat < patend) {
3417       reparse:
3418         datumtype = *pat++ & 0xFF;
3419 #ifdef PERL_NATINT_PACK
3420         natint = 0;
3421 #endif
3422         if (isSPACE(datumtype))
3423             continue;
3424         if (datumtype == '#') {
3425             while (pat < patend && *pat != '\n')
3426                 pat++;
3427             continue;
3428         }
3429         if (*pat == '!') {
3430             char *natstr = "sSiIlL";
3431
3432             if (strchr(natstr, datumtype)) {
3433 #ifdef PERL_NATINT_PACK
3434                 natint = 1;
3435 #endif
3436                 pat++;
3437             }
3438             else
3439                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3440         }
3441         star = 0;
3442         if (pat >= patend)
3443             len = 1;
3444         else if (*pat == '*') {
3445             len = strend - strbeg;      /* long enough */
3446             pat++;
3447             star = 1;
3448         }
3449         else if (isDIGIT(*pat)) {
3450             len = *pat++ - '0';
3451             while (isDIGIT(*pat)) {
3452                 len = (len * 10) + (*pat++ - '0');
3453                 if (len < 0)
3454                     DIE(aTHX_ "Repeat count in unpack overflows");
3455             }
3456         }
3457         else
3458             len = (datumtype != '@');
3459       redo_switch:
3460         switch(datumtype) {
3461         default:
3462             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3463         case ',': /* grandfather in commas but with a warning */
3464             if (commas++ == 0 && ckWARN(WARN_UNPACK))
3465                 Perl_warner(aTHX_ WARN_UNPACK,
3466                             "Invalid type in unpack: '%c'", (int)datumtype);
3467             break;
3468         case '%':
3469             if (len == 1 && pat[-1] != '1')
3470                 len = 16;
3471             checksum = len;
3472             culong = 0;
3473             cdouble = 0;
3474             if (pat < patend)
3475                 goto reparse;
3476             break;
3477         case '@':
3478             if (len > strend - strbeg)
3479                 DIE(aTHX_ "@ outside of string");
3480             s = strbeg + len;
3481             break;
3482         case 'X':
3483             if (len > s - strbeg)
3484                 DIE(aTHX_ "X outside of string");
3485             s -= len;
3486             break;
3487         case 'x':
3488             if (len > strend - s)
3489                 DIE(aTHX_ "x outside of string");
3490             s += len;
3491             break;
3492         case '/':
3493             if (start_sp_offset >= SP - PL_stack_base)
3494                 DIE(aTHX_ "/ must follow a numeric type");
3495             datumtype = *pat++;
3496             if (*pat == '*')
3497                 pat++;          /* ignore '*' for compatibility with pack */
3498             if (isDIGIT(*pat))
3499                 DIE(aTHX_ "/ cannot take a count" );
3500             len = POPi;
3501             star = 0;
3502             goto redo_switch;
3503         case 'A':
3504         case 'Z':
3505         case 'a':
3506             if (len > strend - s)
3507                 len = strend - s;
3508             if (checksum)
3509                 goto uchar_checksum;
3510             sv = NEWSV(35, len);
3511             sv_setpvn(sv, s, len);
3512             s += len;
3513             if (datumtype == 'A' || datumtype == 'Z') {
3514                 aptr = s;       /* borrow register */
3515                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3516                     s = SvPVX(sv);
3517                     while (*s)
3518                         s++;
3519                 }
3520                 else {          /* 'A' strips both nulls and spaces */
3521                     s = SvPVX(sv) + len - 1;
3522                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3523                         s--;
3524                     *++s = '\0';
3525                 }
3526                 SvCUR_set(sv, s - SvPVX(sv));
3527                 s = aptr;       /* unborrow register */
3528             }
3529             XPUSHs(sv_2mortal(sv));
3530             break;
3531         case 'B':
3532         case 'b':
3533             if (star || len > (strend - s) * 8)
3534                 len = (strend - s) * 8;
3535             if (checksum) {
3536                 if (!PL_bitcount) {
3537                     Newz(601, PL_bitcount, 256, char);
3538                     for (bits = 1; bits < 256; bits++) {
3539                         if (bits & 1)   PL_bitcount[bits]++;
3540                         if (bits & 2)   PL_bitcount[bits]++;
3541                         if (bits & 4)   PL_bitcount[bits]++;
3542                         if (bits & 8)   PL_bitcount[bits]++;
3543                         if (bits & 16)  PL_bitcount[bits]++;
3544                         if (bits & 32)  PL_bitcount[bits]++;
3545                         if (bits & 64)  PL_bitcount[bits]++;
3546                         if (bits & 128) PL_bitcount[bits]++;
3547                     }
3548                 }
3549                 while (len >= 8) {
3550                     culong += PL_bitcount[*(unsigned char*)s++];
3551                     len -= 8;
3552                 }
3553                 if (len) {
3554                     bits = *s;
3555                     if (datumtype == 'b') {
3556                         while (len-- > 0) {
3557                             if (bits & 1) culong++;
3558                             bits >>= 1;
3559                         }
3560                     }
3561                     else {
3562                         while (len-- > 0) {
3563                             if (bits & 128) culong++;
3564                             bits <<= 1;
3565                         }
3566                     }
3567                 }
3568                 break;
3569             }
3570             sv = NEWSV(35, len + 1);
3571             SvCUR_set(sv, len);
3572             SvPOK_on(sv);
3573             str = SvPVX(sv);
3574             if (datumtype == 'b') {
3575                 aint = len;
3576                 for (len = 0; len < aint; len++) {
3577                     if (len & 7)                /*SUPPRESS 595*/
3578                         bits >>= 1;
3579                     else
3580                         bits = *s++;
3581                     *str++ = '0' + (bits & 1);
3582                 }
3583             }
3584             else {
3585                 aint = len;
3586                 for (len = 0; len < aint; len++) {
3587                     if (len & 7)
3588                         bits <<= 1;
3589                     else
3590                         bits = *s++;
3591                     *str++ = '0' + ((bits & 128) != 0);
3592                 }
3593             }
3594             *str = '\0';
3595             XPUSHs(sv_2mortal(sv));
3596             break;
3597         case 'H':
3598         case 'h':
3599             if (star || len > (strend - s) * 2)
3600                 len = (strend - s) * 2;
3601             sv = NEWSV(35, len + 1);
3602             SvCUR_set(sv, len);
3603             SvPOK_on(sv);
3604             str = SvPVX(sv);
3605             if (datumtype == 'h') {
3606                 aint = len;
3607                 for (len = 0; len < aint; len++) {
3608                     if (len & 1)
3609                         bits >>= 4;
3610                     else
3611                         bits = *s++;
3612                     *str++ = PL_hexdigit[bits & 15];
3613                 }
3614             }
3615             else {
3616                 aint = len;
3617                 for (len = 0; len < aint; len++) {
3618                     if (len & 1)
3619                         bits <<= 4;
3620                     else
3621                         bits = *s++;
3622                     *str++ = PL_hexdigit[(bits >> 4) & 15];
3623                 }
3624             }
3625             *str = '\0';
3626             XPUSHs(sv_2mortal(sv));
3627             break;
3628         case 'c':
3629             if (len > strend - s)
3630                 len = strend - s;
3631             if (checksum) {
3632                 while (len-- > 0) {
3633                     aint = *s++;
3634                     if (aint >= 128)    /* fake up signed chars */
3635                         aint -= 256;
3636                     culong += aint;
3637                 }
3638             }
3639             else {
3640                 EXTEND(SP, len);
3641                 EXTEND_MORTAL(len);
3642                 while (len-- > 0) {
3643                     aint = *s++;
3644                     if (aint >= 128)    /* fake up signed chars */
3645                         aint -= 256;
3646                     sv = NEWSV(36, 0);
3647                     sv_setiv(sv, (IV)aint);
3648                     PUSHs(sv_2mortal(sv));
3649                 }
3650             }
3651             break;
3652         case 'C':
3653             if (len > strend - s)
3654                 len = strend - s;
3655             if (checksum) {
3656               uchar_checksum:
3657                 while (len-- > 0) {
3658                     auint = *s++ & 255;
3659                     culong += auint;
3660                 }
3661             }
3662             else {
3663                 EXTEND(SP, len);
3664                 EXTEND_MORTAL(len);
3665                 while (len-- > 0) {
3666                     auint = *s++ & 255;
3667                     sv = NEWSV(37, 0);
3668                     sv_setiv(sv, (IV)auint);
3669                     PUSHs(sv_2mortal(sv));
3670                 }
3671             }
3672             break;
3673         case 'U':
3674             if (len > strend - s)
3675                 len = strend - s;
3676             if (checksum) {
3677                 while (len-- > 0 && s < strend) {
3678                     STRLEN alen;
3679                     auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3680                     along = alen;
3681                     s += along;
3682                     if (checksum > 32)
3683                         cdouble += (NV)auint;
3684                     else
3685                         culong += auint;
3686                 }
3687             }
3688             else {
3689                 EXTEND(SP, len);
3690                 EXTEND_MORTAL(len);
3691                 while (len-- > 0 && s < strend) {
3692                     STRLEN alen;
3693                     auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3694                     along = alen;
3695                     s += along;
3696                     sv = NEWSV(37, 0);
3697                     sv_setuv(sv, (UV)auint);
3698                     PUSHs(sv_2mortal(sv));
3699                 }
3700             }
3701             break;
3702         case 's':
3703 #if SHORTSIZE == SIZE16
3704             along = (strend - s) / SIZE16;
3705 #else
3706             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3707 #endif
3708             if (len > along)
3709                 len = along;
3710             if (checksum) {
3711 #if SHORTSIZE != SIZE16
3712                 if (natint) {
3713                     short ashort;
3714                     while (len-- > 0) {
3715                         COPYNN(s, &ashort, sizeof(short));
3716                         s += sizeof(short);
3717                         culong += ashort;
3718
3719                     }
3720                 }
3721                 else
3722 #endif
3723                 {
3724                     while (len-- > 0) {
3725                         COPY16(s, &ashort);
3726 #if SHORTSIZE > SIZE16
3727                         if (ashort > 32767)
3728                           ashort -= 65536;
3729 #endif
3730                         s += SIZE16;
3731                         culong += ashort;
3732                     }
3733                 }
3734             }
3735             else {
3736                 EXTEND(SP, len);
3737                 EXTEND_MORTAL(len);
3738 #if SHORTSIZE != SIZE16
3739                 if (natint) {
3740                     short ashort;
3741                     while (len-- > 0) {
3742                         COPYNN(s, &ashort, sizeof(short));
3743                         s += sizeof(short);
3744                         sv = NEWSV(38, 0);
3745                         sv_setiv(sv, (IV)ashort);
3746                         PUSHs(sv_2mortal(sv));
3747                     }
3748                 }
3749                 else
3750 #endif
3751                 {
3752                     while (len-- > 0) {
3753                         COPY16(s, &ashort);
3754 #if SHORTSIZE > SIZE16
3755                         if (ashort > 32767)
3756                           ashort -= 65536;
3757 #endif
3758                         s += SIZE16;
3759                         sv = NEWSV(38, 0);
3760                         sv_setiv(sv, (IV)ashort);
3761                         PUSHs(sv_2mortal(sv));
3762                     }
3763                 }
3764             }
3765             break;
3766         case 'v':
3767         case 'n':
3768         case 'S':
3769 #if SHORTSIZE == SIZE16
3770             along = (strend - s) / SIZE16;
3771 #else
3772             unatint = natint && datumtype == 'S';
3773             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3774 #endif
3775             if (len > along)
3776                 len = along;
3777             if (checksum) {
3778 #if SHORTSIZE != SIZE16
3779                 if (unatint) {
3780                     unsigned short aushort;
3781                     while (len-- > 0) {
3782                         COPYNN(s, &aushort, sizeof(unsigned short));
3783                         s += sizeof(unsigned short);
3784                         culong += aushort;
3785                     }
3786                 }
3787                 else
3788 #endif
3789                 {
3790                     while (len-- > 0) {
3791                         COPY16(s, &aushort);
3792                         s += SIZE16;
3793 #ifdef HAS_NTOHS
3794                         if (datumtype == 'n')
3795                             aushort = PerlSock_ntohs(aushort);
3796 #endif
3797 #ifdef HAS_VTOHS
3798                         if (datumtype == 'v')
3799                             aushort = vtohs(aushort);
3800 #endif
3801                         culong += aushort;
3802                     }
3803                 }
3804             }
3805             else {
3806                 EXTEND(SP, len);
3807                 EXTEND_MORTAL(len);
3808 #if SHORTSIZE != SIZE16
3809                 if (unatint) {
3810                     unsigned short aushort;
3811                     while (len-- > 0) {
3812                         COPYNN(s, &aushort, sizeof(unsigned short));
3813                         s += sizeof(unsigned short);
3814                         sv = NEWSV(39, 0);
3815                         sv_setiv(sv, (UV)aushort);
3816                         PUSHs(sv_2mortal(sv));
3817                     }
3818                 }
3819                 else
3820 #endif
3821                 {
3822                     while (len-- > 0) {
3823                         COPY16(s, &aushort);
3824                         s += SIZE16;
3825                         sv = NEWSV(39, 0);
3826 #ifdef HAS_NTOHS
3827                         if (datumtype == 'n')
3828                             aushort = PerlSock_ntohs(aushort);
3829 #endif
3830 #ifdef HAS_VTOHS
3831                         if (datumtype == 'v')
3832                             aushort = vtohs(aushort);
3833 #endif
3834                         sv_setiv(sv, (UV)aushort);
3835                         PUSHs(sv_2mortal(sv));
3836                     }
3837                 }
3838             }
3839             break;
3840         case 'i':
3841             along = (strend - s) / sizeof(int);
3842             if (len > along)
3843                 len = along;
3844             if (checksum) {
3845                 while (len-- > 0) {
3846                     Copy(s, &aint, 1, int);
3847                     s += sizeof(int);
3848                     if (checksum > 32)
3849                         cdouble += (NV)aint;
3850                     else
3851                         culong += aint;
3852                 }
3853             }
3854             else {
3855                 EXTEND(SP, len);
3856                 EXTEND_MORTAL(len);
3857                 while (len-- > 0) {
3858                     Copy(s, &aint, 1, int);
3859                     s += sizeof(int);
3860                     sv = NEWSV(40, 0);
3861 #ifdef __osf__
3862                     /* Without the dummy below unpack("i", pack("i",-1))
3863                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3864                      * cc with optimization turned on.
3865                      *
3866                      * The bug was detected in
3867                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3868                      * with optimization (-O4) turned on.
3869                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3870                      * does not have this problem even with -O4.
3871                      *
3872                      * This bug was reported as DECC_BUGS 1431
3873                      * and tracked internally as GEM_BUGS 7775.
3874                      *
3875                      * The bug is fixed in
3876                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3877                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3878                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3879                      * and also in DTK.
3880                      *
3881                      * See also few lines later for the same bug.
3882                      */
3883                     (aint) ?
3884                         sv_setiv(sv, (IV)aint) :
3885 #endif
3886                     sv_setiv(sv, (IV)aint);
3887                     PUSHs(sv_2mortal(sv));
3888                 }
3889             }
3890             break;
3891         case 'I':
3892             along = (strend - s) / sizeof(unsigned int);
3893             if (len > along)
3894                 len = along;
3895             if (checksum) {
3896                 while (len-- > 0) {
3897                     Copy(s, &auint, 1, unsigned int);
3898                     s += sizeof(unsigned int);
3899                     if (checksum > 32)
3900                         cdouble += (NV)auint;
3901                     else
3902                         culong += auint;
3903                 }
3904             }
3905             else {
3906                 EXTEND(SP, len);
3907                 EXTEND_MORTAL(len);
3908                 while (len-- > 0) {
3909                     Copy(s, &auint, 1, unsigned int);
3910                     s += sizeof(unsigned int);
3911                     sv = NEWSV(41, 0);
3912 #ifdef __osf__
3913                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3914                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3915                      * See details few lines earlier. */
3916                     (auint) ?
3917                         sv_setuv(sv, (UV)auint) :
3918 #endif
3919                     sv_setuv(sv, (UV)auint);
3920                     PUSHs(sv_2mortal(sv));
3921                 }
3922             }
3923             break;
3924         case 'l':
3925 #if LONGSIZE == SIZE32
3926             along = (strend - s) / SIZE32;
3927 #else
3928             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3929 #endif
3930             if (len > along)
3931                 len = along;
3932             if (checksum) {
3933 #if LONGSIZE != SIZE32
3934                 if (natint) {
3935                     while (len-- > 0) {
3936                         COPYNN(s, &along, sizeof(long));
3937                         s += sizeof(long);
3938                         if (checksum > 32)
3939                             cdouble += (NV)along;
3940                         else
3941                             culong += along;
3942                     }
3943                 }
3944                 else
3945 #endif
3946                 {
3947                     while (len-- > 0) {
3948 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3949                         I32 along;
3950 #endif
3951                         COPY32(s, &along);
3952 #if LONGSIZE > SIZE32
3953                         if (along > 2147483647)
3954                           along -= 4294967296;
3955 #endif
3956                         s += SIZE32;
3957                         if (checksum > 32)
3958                             cdouble += (NV)along;
3959                         else
3960                             culong += along;
3961                     }
3962                 }
3963             }
3964             else {
3965                 EXTEND(SP, len);
3966                 EXTEND_MORTAL(len);
3967 #if LONGSIZE != SIZE32
3968                 if (natint) {
3969                     while (len-- > 0) {
3970                         COPYNN(s, &along, sizeof(long));
3971                         s += sizeof(long);
3972                         sv = NEWSV(42, 0);
3973                         sv_setiv(sv, (IV)along);
3974                         PUSHs(sv_2mortal(sv));
3975                     }
3976                 }
3977                 else
3978 #endif
3979                 {
3980                     while (len-- > 0) {
3981 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3982                         I32 along;
3983 #endif
3984                         COPY32(s, &along);
3985 #if LONGSIZE > SIZE32
3986                         if (along > 2147483647)
3987                           along -= 4294967296;
3988 #endif
3989                         s += SIZE32;
3990                         sv = NEWSV(42, 0);
3991                         sv_setiv(sv, (IV)along);
3992                         PUSHs(sv_2mortal(sv));
3993                     }
3994                 }
3995             }
3996             break;
3997         case 'V':
3998         case 'N':
3999         case 'L':
4000 #if LONGSIZE == SIZE32
4001             along = (strend - s) / SIZE32;
4002 #else
4003             unatint = natint && datumtype == 'L';
4004             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4005 #endif
4006             if (len > along)
4007                 len = along;
4008             if (checksum) {
4009 #if LONGSIZE != SIZE32
4010                 if (unatint) {
4011                     unsigned long aulong;
4012                     while (len-- > 0) {
4013                         COPYNN(s, &aulong, sizeof(unsigned long));
4014                         s += sizeof(unsigned long);
4015                         if (checksum > 32)
4016                             cdouble += (NV)aulong;
4017                         else
4018                             culong += aulong;
4019                     }
4020                 }
4021                 else
4022 #endif
4023                 {
4024                     while (len-- > 0) {
4025                         COPY32(s, &aulong);
4026                         s += SIZE32;
4027 #ifdef HAS_NTOHL
4028                         if (datumtype == 'N')
4029                             aulong = PerlSock_ntohl(aulong);
4030 #endif
4031 #ifdef HAS_VTOHL
4032                         if (datumtype == 'V')
4033                             aulong = vtohl(aulong);
4034 #endif
4035                         if (checksum > 32)
4036                             cdouble += (NV)aulong;
4037                         else
4038                             culong += aulong;
4039                     }
4040                 }
4041             }
4042             else {
4043                 EXTEND(SP, len);
4044                 EXTEND_MORTAL(len);
4045 #if LONGSIZE != SIZE32
4046                 if (unatint) {
4047                     unsigned long aulong;
4048                     while (len-- > 0) {
4049                         COPYNN(s, &aulong, sizeof(unsigned long));
4050                         s += sizeof(unsigned long);
4051                         sv = NEWSV(43, 0);
4052                         sv_setuv(sv, (UV)aulong);
4053                         PUSHs(sv_2mortal(sv));
4054                     }
4055                 }
4056                 else
4057 #endif
4058                 {
4059                     while (len-- > 0) {
4060                         COPY32(s, &aulong);
4061                         s += SIZE32;
4062 #ifdef HAS_NTOHL
4063                         if (datumtype == 'N')
4064                             aulong = PerlSock_ntohl(aulong);
4065 #endif
4066 #ifdef HAS_VTOHL
4067                         if (datumtype == 'V')
4068                             aulong = vtohl(aulong);
4069 #endif
4070                         sv = NEWSV(43, 0);
4071                         sv_setuv(sv, (UV)aulong);
4072                         PUSHs(sv_2mortal(sv));
4073                     }
4074                 }
4075             }
4076             break;
4077         case 'p':
4078             along = (strend - s) / sizeof(char*);
4079             if (len > along)
4080                 len = along;
4081             EXTEND(SP, len);
4082             EXTEND_MORTAL(len);
4083             while (len-- > 0) {
4084                 if (sizeof(char*) > strend - s)
4085                     break;
4086                 else {
4087                     Copy(s, &aptr, 1, char*);
4088                     s += sizeof(char*);
4089                 }
4090                 sv = NEWSV(44, 0);
4091                 if (aptr)
4092                     sv_setpv(sv, aptr);
4093                 PUSHs(sv_2mortal(sv));
4094             }
4095             break;
4096         case 'w':
4097             EXTEND(SP, len);
4098             EXTEND_MORTAL(len);
4099             {
4100                 UV auv = 0;
4101                 U32 bytes = 0;
4102
4103                 while ((len > 0) && (s < strend)) {
4104                     auv = (auv << 7) | (*s & 0x7f);
4105                     if (!(*s++ & 0x80)) {
4106                         bytes = 0;
4107                         sv = NEWSV(40, 0);
4108                         sv_setuv(sv, auv);
4109                         PUSHs(sv_2mortal(sv));
4110                         len--;
4111                         auv = 0;
4112                     }
4113                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4114                         char *t;
4115                         STRLEN n_a;
4116
4117                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4118                         while (s < strend) {
4119                             sv = mul128(sv, *s & 0x7f);
4120                             if (!(*s++ & 0x80)) {
4121                                 bytes = 0;
4122                                 break;
4123                             }
4124                         }
4125                         t = SvPV(sv, n_a);
4126                         while (*t == '0')
4127                             t++;
4128                         sv_chop(sv, t);
4129                         PUSHs(sv_2mortal(sv));
4130                         len--;
4131                         auv = 0;
4132                     }
4133                 }
4134                 if ((s >= strend) && bytes)
4135                     DIE(aTHX_ "Unterminated compressed integer");
4136             }
4137             break;
4138         case 'P':
4139             EXTEND(SP, 1);
4140             if (sizeof(char*) > strend - s)
4141                 break;
4142             else {
4143                 Copy(s, &aptr, 1, char*);
4144                 s += sizeof(char*);
4145             }
4146             sv = NEWSV(44, 0);
4147             if (aptr)
4148                 sv_setpvn(sv, aptr, len);
4149             PUSHs(sv_2mortal(sv));
4150             break;
4151 #ifdef HAS_QUAD
4152         case 'q':
4153             along = (strend - s) / sizeof(Quad_t);
4154             if (len > along)
4155                 len = along;
4156             EXTEND(SP, len);
4157             EXTEND_MORTAL(len);
4158             while (len-- > 0) {
4159                 if (s + sizeof(Quad_t) > strend)
4160                     aquad = 0;
4161                 else {
4162                     Copy(s, &aquad, 1, Quad_t);
4163                     s += sizeof(Quad_t);
4164                 }
4165                 sv = NEWSV(42, 0);
4166                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4167                     sv_setiv(sv, (IV)aquad);
4168                 else
4169                     sv_setnv(sv, (NV)aquad);
4170                 PUSHs(sv_2mortal(sv));
4171             }
4172             break;
4173         case 'Q':
4174             along = (strend - s) / sizeof(Quad_t);
4175             if (len > along)
4176                 len = along;
4177             EXTEND(SP, len);
4178             EXTEND_MORTAL(len);
4179             while (len-- > 0) {
4180                 if (s + sizeof(Uquad_t) > strend)
4181                     auquad = 0;
4182                 else {
4183                     Copy(s, &auquad, 1, Uquad_t);
4184                     s += sizeof(Uquad_t);
4185                 }
4186                 sv = NEWSV(43, 0);
4187                 if (auquad <= UV_MAX)
4188                     sv_setuv(sv, (UV)auquad);
4189                 else
4190                     sv_setnv(sv, (NV)auquad);
4191                 PUSHs(sv_2mortal(sv));
4192             }
4193             break;
4194 #endif
4195         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4196         case 'f':
4197         case 'F':
4198             along = (strend - s) / sizeof(float);
4199             if (len > along)
4200                 len = along;
4201             if (checksum) {
4202                 while (len-- > 0) {
4203                     Copy(s, &afloat, 1, float);
4204                     s += sizeof(float);
4205                     cdouble += afloat;
4206                 }
4207             }
4208             else {
4209                 EXTEND(SP, len);
4210                 EXTEND_MORTAL(len);
4211                 while (len-- > 0) {
4212                     Copy(s, &afloat, 1, float);
4213                     s += sizeof(float);
4214                     sv = NEWSV(47, 0);
4215                     sv_setnv(sv, (NV)afloat);
4216                     PUSHs(sv_2mortal(sv));
4217                 }
4218             }
4219             break;
4220         case 'd':
4221         case 'D':
4222             along = (strend - s) / sizeof(double);
4223             if (len > along)
4224                 len = along;
4225             if (checksum) {
4226                 while (len-- > 0) {
4227                     Copy(s, &adouble, 1, double);
4228                     s += sizeof(double);
4229                     cdouble += adouble;
4230                 }
4231             }
4232             else {
4233                 EXTEND(SP, len);
4234                 EXTEND_MORTAL(len);
4235                 while (len-- > 0) {
4236                     Copy(s, &adouble, 1, double);
4237                     s += sizeof(double);
4238                     sv = NEWSV(48, 0);
4239                     sv_setnv(sv, (NV)adouble);
4240                     PUSHs(sv_2mortal(sv));
4241                 }
4242             }
4243             break;
4244         case 'u':
4245             /* MKS:
4246              * Initialise the decode mapping.  By using a table driven
4247              * algorithm, the code will be character-set independent
4248              * (and just as fast as doing character arithmetic)
4249              */
4250             if (PL_uudmap['M'] == 0) {
4251                 int i;
4252
4253                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4254                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4255                 /*
4256                  * Because ' ' and '`' map to the same value,
4257                  * we need to decode them both the same.
4258                  */
4259                 PL_uudmap[' '] = 0;
4260             }
4261
4262             along = (strend - s) * 3 / 4;
4263             sv = NEWSV(42, along);
4264             if (along)
4265                 SvPOK_on(sv);
4266             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4267                 I32 a, b, c, d;
4268                 char hunk[4];
4269
4270                 hunk[3] = '\0';
4271                 len = PL_uudmap[*(U8*)s++] & 077;
4272                 while (len > 0) {
4273                     if (s < strend && ISUUCHAR(*s))
4274                         a = PL_uudmap[*(U8*)s++] & 077;
4275                     else
4276                         a = 0;
4277                     if (s < strend && ISUUCHAR(*s))
4278                         b = PL_uudmap[*(U8*)s++] & 077;
4279                     else
4280                         b = 0;
4281                     if (s < strend && ISUUCHAR(*s))
4282                         c = PL_uudmap[*(U8*)s++] & 077;
4283                     else
4284                         c = 0;
4285                     if (s < strend && ISUUCHAR(*s))
4286                         d = PL_uudmap[*(U8*)s++] & 077;
4287                     else
4288                         d = 0;
4289                     hunk[0] = (a << 2) | (b >> 4);
4290                     hunk[1] = (b << 4) | (c >> 2);
4291                     hunk[2] = (c << 6) | d;
4292                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4293                     len -= 3;
4294                 }
4295                 if (*s == '\n')
4296                     s++;
4297                 else if (s[1] == '\n')          /* possible checksum byte */
4298                     s += 2;
4299             }
4300             XPUSHs(sv_2mortal(sv));
4301             break;
4302         }
4303         if (checksum) {
4304             sv = NEWSV(42, 0);
4305             if (strchr("fFdD", datumtype) ||
4306               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4307                 NV trouble;
4308
4309                 adouble = 1.0;
4310                 while (checksum >= 16) {
4311                     checksum -= 16;
4312                     adouble *= 65536.0;
4313                 }
4314                 while (checksum >= 4) {
4315                     checksum -= 4;
4316                     adouble *= 16.0;
4317                 }
4318                 while (checksum--)
4319                     adouble *= 2.0;
4320                 along = (1 << checksum) - 1;
4321                 while (cdouble < 0.0)
4322                     cdouble += adouble;
4323                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4324                 sv_setnv(sv, cdouble);
4325             }
4326             else {
4327                 if (checksum < 32) {
4328                     aulong = (1 << checksum) - 1;
4329                     culong &= aulong;
4330                 }
4331                 sv_setuv(sv, (UV)culong);
4332             }
4333             XPUSHs(sv_2mortal(sv));
4334             checksum = 0;
4335         }
4336     }
4337     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4338         PUSHs(&PL_sv_undef);
4339     RETURN;
4340 }
4341
4342 STATIC void
4343 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4344 {
4345     char hunk[5];
4346
4347     *hunk = PL_uuemap[len];
4348     sv_catpvn(sv, hunk, 1);
4349     hunk[4] = '\0';
4350     while (len > 2) {
4351         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4352         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4353         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4354         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4355         sv_catpvn(sv, hunk, 4);
4356         s += 3;
4357         len -= 3;
4358     }
4359     if (len > 0) {
4360         char r = (len > 1 ? s[1] : '\0');
4361         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4362         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4363         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4364         hunk[3] = PL_uuemap[0];
4365         sv_catpvn(sv, hunk, 4);
4366     }
4367     sv_catpvn(sv, "\n", 1);
4368 }
4369
4370 STATIC SV *
4371 S_is_an_int(pTHX_ char *s, STRLEN l)
4372 {
4373   STRLEN         n_a;
4374   SV             *result = newSVpvn(s, l);
4375   char           *result_c = SvPV(result, n_a); /* convenience */
4376   char           *out = result_c;
4377   bool            skip = 1;
4378   bool            ignore = 0;
4379
4380   while (*s) {
4381     switch (*s) {
4382     case ' ':
4383       break;
4384     case '+':
4385       if (!skip) {
4386         SvREFCNT_dec(result);
4387         return (NULL);
4388       }
4389       break;
4390     case '0':
4391     case '1':
4392     case '2':
4393     case '3':
4394     case '4':
4395     case '5':
4396     case '6':
4397     case '7':
4398     case '8':
4399     case '9':
4400       skip = 0;
4401       if (!ignore) {
4402         *(out++) = *s;
4403       }
4404       break;
4405     case '.':
4406       ignore = 1;
4407       break;
4408     default:
4409       SvREFCNT_dec(result);
4410       return (NULL);
4411     }
4412     s++;
4413   }
4414   *(out++) = '\0';
4415   SvCUR_set(result, out - result_c);
4416   return (result);
4417 }
4418
4419 /* pnum must be '\0' terminated */
4420 STATIC int
4421 S_div128(pTHX_ SV *pnum, bool *done)
4422 {
4423   STRLEN          len;
4424   char           *s = SvPV(pnum, len);
4425   int             m = 0;
4426   int             r = 0;
4427   char           *t = s;
4428
4429   *done = 1;
4430   while (*t) {
4431     int             i;
4432
4433     i = m * 10 + (*t - '0');
4434     m = i & 0x7F;
4435     r = (i >> 7);               /* r < 10 */
4436     if (r) {
4437       *done = 0;
4438     }
4439     *(t++) = '0' + r;
4440   }
4441   *(t++) = '\0';
4442   SvCUR_set(pnum, (STRLEN) (t - s));
4443   return (m);
4444 }
4445
4446
4447 PP(pp_pack)
4448 {
4449     djSP; dMARK; dORIGMARK; dTARGET;
4450     register SV *cat = TARG;
4451     register I32 items;
4452     STRLEN fromlen;
4453     register char *pat = SvPVx(*++MARK, fromlen);
4454     char *patcopy;
4455     register char *patend = pat + fromlen;
4456     register I32 len;
4457     I32 datumtype;
4458     SV *fromstr;
4459     /*SUPPRESS 442*/
4460     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4461     static char *space10 = "          ";
4462
4463     /* These must not be in registers: */
4464     char achar;
4465     I16 ashort;
4466     int aint;
4467     unsigned int auint;
4468     I32 along;
4469     U32 aulong;
4470 #ifdef HAS_QUAD
4471     Quad_t aquad;
4472     Uquad_t auquad;
4473 #endif
4474     char *aptr;
4475     float afloat;
4476     double adouble;
4477     int commas = 0;
4478 #ifdef PERL_NATINT_PACK
4479     int natint;         /* native integer */
4480 #endif
4481
4482     items = SP - MARK;
4483     MARK++;
4484     sv_setpvn(cat, "", 0);
4485     patcopy = pat;
4486     while (pat < patend) {
4487         SV *lengthcode = Nullsv;
4488 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4489         datumtype = *pat++ & 0xFF;
4490 #ifdef PERL_NATINT_PACK
4491         natint = 0;
4492 #endif
4493         if (isSPACE(datumtype)) {
4494             patcopy++;
4495             continue;
4496         }
4497         if (datumtype == 'U' && pat == patcopy+1)
4498             SvUTF8_on(cat);
4499         if (datumtype == '#') {
4500             while (pat < patend && *pat != '\n')
4501                 pat++;
4502             continue;
4503         }
4504         if (*pat == '!') {
4505             char *natstr = "sSiIlL";
4506
4507             if (strchr(natstr, datumtype)) {
4508 #ifdef PERL_NATINT_PACK
4509                 natint = 1;
4510 #endif
4511                 pat++;
4512             }
4513             else
4514                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4515         }
4516         if (*pat == '*') {
4517             len = strchr("@Xxu", datumtype) ? 0 : items;
4518             pat++;
4519         }
4520         else if (isDIGIT(*pat)) {
4521             len = *pat++ - '0';
4522             while (isDIGIT(*pat)) {
4523                 len = (len * 10) + (*pat++ - '0');
4524                 if (len < 0)
4525                     DIE(aTHX_ "Repeat count in pack overflows");
4526             }
4527         }
4528         else
4529             len = 1;
4530         if (*pat == '/') {
4531             ++pat;
4532             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4533                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4534             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4535                                                    ? *MARK : &PL_sv_no)
4536                                             + (*pat == 'Z' ? 1 : 0)));
4537         }
4538         switch(datumtype) {
4539         default:
4540             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4541         case ',': /* grandfather in commas but with a warning */
4542             if (commas++ == 0 && ckWARN(WARN_PACK))
4543                 Perl_warner(aTHX_ WARN_PACK,
4544                             "Invalid type in pack: '%c'", (int)datumtype);
4545             break;
4546         case '%':
4547             DIE(aTHX_ "%% may only be used in unpack");
4548         case '@':
4549             len -= SvCUR(cat);
4550             if (len > 0)
4551                 goto grow;
4552             len = -len;
4553             if (len > 0)
4554                 goto shrink;
4555             break;
4556         case 'X':
4557           shrink:
4558             if (SvCUR(cat) < len)
4559                 DIE(aTHX_ "X outside of string");
4560             SvCUR(cat) -= len;
4561             *SvEND(cat) = '\0';
4562             break;
4563         case 'x':
4564           grow:
4565             while (len >= 10) {
4566                 sv_catpvn(cat, null10, 10);
4567                 len -= 10;
4568             }
4569             sv_catpvn(cat, null10, len);
4570             break;
4571         case 'A':
4572         case 'Z':
4573         case 'a':
4574             fromstr = NEXTFROM;
4575             aptr = SvPV(fromstr, fromlen);
4576             if (pat[-1] == '*') {
4577                 len = fromlen;
4578                 if (datumtype == 'Z')
4579                     ++len;
4580             }
4581             if (fromlen >= len) {
4582                 sv_catpvn(cat, aptr, len);
4583                 if (datumtype == 'Z')
4584                     *(SvEND(cat)-1) = '\0';
4585             }
4586             else {
4587                 sv_catpvn(cat, aptr, fromlen);
4588                 len -= fromlen;
4589                 if (datumtype == 'A') {
4590                     while (len >= 10) {
4591                         sv_catpvn(cat, space10, 10);
4592                         len -= 10;
4593                     }
4594                     sv_catpvn(cat, space10, len);
4595                 }
4596                 else {
4597                     while (len >= 10) {
4598                         sv_catpvn(cat, null10, 10);
4599                         len -= 10;
4600                     }
4601                     sv_catpvn(cat, null10, len);
4602                 }
4603             }
4604             break;
4605         case 'B':
4606         case 'b':
4607             {
4608                 register char *str;
4609                 I32 saveitems;
4610
4611                 fromstr = NEXTFROM;
4612                 saveitems = items;
4613                 str = SvPV(fromstr, fromlen);
4614                 if (pat[-1] == '*')
4615                     len = fromlen;
4616                 aint = SvCUR(cat);
4617                 SvCUR(cat) += (len+7)/8;
4618                 SvGROW(cat, SvCUR(cat) + 1);
4619                 aptr = SvPVX(cat) + aint;
4620                 if (len > fromlen)
4621                     len = fromlen;
4622                 aint = len;
4623                 items = 0;
4624                 if (datumtype == 'B') {
4625                     for (len = 0; len++ < aint;) {
4626                         items |= *str++ & 1;
4627                         if (len & 7)
4628                             items <<= 1;
4629                         else {
4630                             *aptr++ = items & 0xff;
4631                             items = 0;
4632                         }
4633                     }
4634                 }
4635                 else {
4636                     for (len = 0; len++ < aint;) {
4637                         if (*str++ & 1)
4638                             items |= 128;
4639                         if (len & 7)
4640                             items >>= 1;
4641                         else {
4642                             *aptr++ = items & 0xff;
4643                             items = 0;
4644                         }
4645                     }
4646                 }
4647                 if (aint & 7) {
4648                     if (datumtype == 'B')
4649                         items <<= 7 - (aint & 7);
4650                     else
4651                         items >>= 7 - (aint & 7);
4652                     *aptr++ = items & 0xff;
4653                 }
4654                 str = SvPVX(cat) + SvCUR(cat);
4655                 while (aptr <= str)
4656                     *aptr++ = '\0';
4657
4658                 items = saveitems;
4659             }
4660             break;
4661         case 'H':
4662         case 'h':
4663             {
4664                 register char *str;
4665                 I32 saveitems;
4666
4667                 fromstr = NEXTFROM;
4668                 saveitems = items;
4669                 str = SvPV(fromstr, fromlen);
4670                 if (pat[-1] == '*')
4671                     len = fromlen;
4672                 aint = SvCUR(cat);
4673                 SvCUR(cat) += (len+1)/2;
4674                 SvGROW(cat, SvCUR(cat) + 1);
4675                 aptr = SvPVX(cat) + aint;
4676                 if (len > fromlen)
4677                     len = fromlen;
4678                 aint = len;
4679                 items = 0;
4680                 if (datumtype == 'H') {
4681                     for (len = 0; len++ < aint;) {
4682                         if (isALPHA(*str))
4683                             items |= ((*str++ & 15) + 9) & 15;
4684                         else
4685                             items |= *str++ & 15;
4686                         if (len & 1)
4687                             items <<= 4;
4688                         else {
4689                             *aptr++ = items & 0xff;
4690                             items = 0;
4691                         }
4692                     }
4693                 }
4694                 else {
4695                     for (len = 0; len++ < aint;) {
4696                         if (isALPHA(*str))
4697                             items |= (((*str++ & 15) + 9) & 15) << 4;
4698                         else
4699                             items |= (*str++ & 15) << 4;
4700                         if (len & 1)
4701                             items >>= 4;
4702                         else {
4703                             *aptr++ = items & 0xff;
4704                             items = 0;
4705                         }
4706                     }
4707                 }
4708                 if (aint & 1)
4709                     *aptr++ = items & 0xff;
4710                 str = SvPVX(cat) + SvCUR(cat);
4711                 while (aptr <= str)
4712                     *aptr++ = '\0';
4713
4714                 items = saveitems;
4715             }
4716             break;
4717         case 'C':
4718         case 'c':
4719             while (len-- > 0) {
4720                 fromstr = NEXTFROM;
4721                 aint = SvIV(fromstr);
4722                 achar = aint;
4723                 sv_catpvn(cat, &achar, sizeof(char));
4724             }
4725             break;
4726         case 'U':
4727             while (len-- > 0) {
4728                 fromstr = NEXTFROM;
4729                 auint = SvUV(fromstr);
4730                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4731                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4732                                - SvPVX(cat));
4733             }
4734             *SvEND(cat) = '\0';
4735             break;
4736         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4737         case 'f':
4738         case 'F':
4739             while (len-- > 0) {
4740                 fromstr = NEXTFROM;
4741                 afloat = (float)SvNV(fromstr);
4742                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4743             }
4744             break;
4745         case 'd':
4746         case 'D':
4747             while (len-- > 0) {
4748                 fromstr = NEXTFROM;
4749                 adouble = (double)SvNV(fromstr);
4750                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4751             }
4752             break;
4753         case 'n':
4754             while (len-- > 0) {
4755                 fromstr = NEXTFROM;
4756                 ashort = (I16)SvIV(fromstr);
4757 #ifdef HAS_HTONS
4758                 ashort = PerlSock_htons(ashort);
4759 #endif
4760                 CAT16(cat, &ashort);
4761             }
4762             break;
4763         case 'v':
4764             while (len-- > 0) {
4765                 fromstr = NEXTFROM;
4766                 ashort = (I16)SvIV(fromstr);
4767 #ifdef HAS_HTOVS
4768                 ashort = htovs(ashort);
4769 #endif
4770                 CAT16(cat, &ashort);
4771             }
4772             break;
4773         case 'S':
4774 #if SHORTSIZE != SIZE16
4775             if (natint) {
4776                 unsigned short aushort;
4777
4778                 while (len-- > 0) {
4779                     fromstr = NEXTFROM;
4780                     aushort = SvUV(fromstr);
4781                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4782                 }
4783             }
4784             else
4785 #endif
4786             {
4787                 U16 aushort;
4788
4789                 while (len-- > 0) {
4790                     fromstr = NEXTFROM;
4791                     aushort = (U16)SvUV(fromstr);
4792                     CAT16(cat, &aushort);
4793                 }
4794
4795             }
4796             break;
4797         case 's':
4798 #if SHORTSIZE != SIZE16
4799             if (natint) {
4800                 short ashort;
4801
4802                 while (len-- > 0) {
4803                     fromstr = NEXTFROM;
4804                     ashort = SvIV(fromstr);
4805                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4806                 }
4807             }
4808             else
4809 #endif
4810             {
4811                 while (len-- > 0) {
4812                     fromstr = NEXTFROM;
4813                     ashort = (I16)SvIV(fromstr);
4814                     CAT16(cat, &ashort);
4815                 }
4816             }
4817             break;
4818         case 'I':
4819             while (len-- > 0) {
4820                 fromstr = NEXTFROM;
4821                 auint = SvUV(fromstr);
4822                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4823             }
4824             break;
4825         case 'w':
4826             while (len-- > 0) {
4827                 fromstr = NEXTFROM;
4828                 adouble = Perl_floor(SvNV(fromstr));
4829
4830                 if (adouble < 0)
4831                     DIE(aTHX_ "Cannot compress negative numbers");
4832
4833                 if (
4834 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4835                     adouble <= 0xffffffff
4836 #else
4837 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
4838                     adouble <= UV_MAX_cxux
4839 #   else
4840                     adouble <= UV_MAX
4841 #   endif
4842 #endif
4843                     )
4844                 {
4845                     char   buf[1 + sizeof(UV)];
4846                     char  *in = buf + sizeof(buf);
4847                     UV     auv = U_V(adouble);
4848
4849                     do {
4850                         *--in = (auv & 0x7f) | 0x80;
4851                         auv >>= 7;
4852                     } while (auv);
4853                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4854                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4855                 }
4856                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4857                     char           *from, *result, *in;
4858                     SV             *norm;
4859                     STRLEN          len;
4860                     bool            done;
4861
4862                     /* Copy string and check for compliance */
4863                     from = SvPV(fromstr, len);
4864                     if ((norm = is_an_int(from, len)) == NULL)
4865                         DIE(aTHX_ "can compress only unsigned integer");
4866
4867                     New('w', result, len, char);
4868                     in = result + len;
4869                     done = FALSE;
4870                     while (!done)
4871                         *--in = div128(norm, &done) | 0x80;
4872                     result[len - 1] &= 0x7F; /* clear continue bit */
4873                     sv_catpvn(cat, in, (result + len) - in);
4874                     Safefree(result);
4875                     SvREFCNT_dec(norm); /* free norm */
4876                 }
4877                 else if (SvNOKp(fromstr)) {
4878                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4879                     char  *in = buf + sizeof(buf);
4880
4881                     do {
4882                         double next = floor(adouble / 128);
4883                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4884                         if (in <= buf)  /* this cannot happen ;-) */
4885                             DIE(aTHX_ "Cannot compress integer");
4886                         in--;
4887                         adouble = next;
4888                     } while (adouble > 0);
4889                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4890                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4891                 }
4892                 else
4893                     DIE(aTHX_ "Cannot compress non integer");
4894             }
4895             break;
4896         case 'i':
4897             while (len-- > 0) {
4898                 fromstr = NEXTFROM;
4899                 aint = SvIV(fromstr);
4900                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4901             }
4902             break;
4903         case 'N':
4904             while (len-- > 0) {
4905                 fromstr = NEXTFROM;
4906                 aulong = SvUV(fromstr);
4907 #ifdef HAS_HTONL
4908                 aulong = PerlSock_htonl(aulong);
4909 #endif
4910                 CAT32(cat, &aulong);
4911             }
4912             break;
4913         case 'V':
4914             while (len-- > 0) {
4915                 fromstr = NEXTFROM;
4916                 aulong = SvUV(fromstr);
4917 #ifdef HAS_HTOVL
4918                 aulong = htovl(aulong);
4919 #endif
4920                 CAT32(cat, &aulong);
4921             }
4922             break;
4923         case 'L':
4924 #if LONGSIZE != SIZE32
4925             if (natint) {
4926                 unsigned long aulong;
4927
4928                 while (len-- > 0) {
4929                     fromstr = NEXTFROM;
4930                     aulong = SvUV(fromstr);
4931                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4932                 }
4933             }
4934             else
4935 #endif
4936             {
4937                 while (len-- > 0) {
4938                     fromstr = NEXTFROM;
4939                     aulong = SvUV(fromstr);
4940                     CAT32(cat, &aulong);
4941                 }
4942             }
4943             break;
4944         case 'l':
4945 #if LONGSIZE != SIZE32
4946             if (natint) {
4947                 long along;
4948
4949                 while (len-- > 0) {
4950                     fromstr = NEXTFROM;
4951                     along = SvIV(fromstr);
4952                     sv_catpvn(cat, (char *)&along, sizeof(long));
4953                 }
4954             }
4955             else
4956 #endif
4957             {
4958                 while (len-- > 0) {
4959                     fromstr = NEXTFROM;
4960                     along = SvIV(fromstr);
4961                     CAT32(cat, &along);
4962                 }
4963             }
4964             break;
4965 #ifdef HAS_QUAD
4966         case 'Q':
4967             while (len-- > 0) {
4968                 fromstr = NEXTFROM;
4969                 auquad = (Uquad_t)SvUV(fromstr);
4970                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4971             }
4972             break;
4973         case 'q':
4974             while (len-- > 0) {
4975                 fromstr = NEXTFROM;
4976                 aquad = (Quad_t)SvIV(fromstr);
4977                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4978             }
4979             break;
4980 #endif
4981         case 'P':
4982             len = 1;            /* assume SV is correct length */
4983             /* FALL THROUGH */
4984         case 'p':
4985             while (len-- > 0) {
4986                 fromstr = NEXTFROM;
4987                 if (fromstr == &PL_sv_undef)
4988                     aptr = NULL;
4989                 else {
4990                     STRLEN n_a;
4991                     /* XXX better yet, could spirit away the string to
4992                      * a safe spot and hang on to it until the result
4993                      * of pack() (and all copies of the result) are
4994                      * gone.
4995                      */
4996                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4997                                                 || (SvPADTMP(fromstr)
4998                                                     && !SvREADONLY(fromstr))))
4999                     {
5000                         Perl_warner(aTHX_ WARN_PACK,
5001                                 "Attempt to pack pointer to temporary value");
5002                     }
5003                     if (SvPOK(fromstr) || SvNIOK(fromstr))
5004                         aptr = SvPV(fromstr,n_a);
5005                     else
5006                         aptr = SvPV_force(fromstr,n_a);
5007                 }
5008                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5009             }
5010             break;
5011         case 'u':
5012             fromstr = NEXTFROM;
5013             aptr = SvPV(fromstr, fromlen);
5014             SvGROW(cat, fromlen * 4 / 3);
5015             if (len <= 1)
5016                 len = 45;
5017             else
5018                 len = len / 3 * 3;
5019             while (fromlen > 0) {
5020                 I32 todo;
5021
5022                 if (fromlen > len)
5023                     todo = len;
5024                 else
5025                     todo = fromlen;
5026                 doencodes(cat, aptr, todo);
5027                 fromlen -= todo;
5028                 aptr += todo;
5029             }
5030             break;
5031         }
5032     }
5033     SvSETMAGIC(cat);
5034     SP = ORIGMARK;
5035     PUSHs(cat);
5036     RETURN;
5037 }
5038 #undef NEXTFROM
5039
5040
5041 PP(pp_split)
5042 {
5043     djSP; dTARG;
5044     AV *ary;
5045     register IV limit = POPi;                   /* note, negative is forever */
5046     SV *sv = POPs;
5047     bool doutf8 = DO_UTF8(sv);
5048     STRLEN len;
5049     register char *s = SvPV(sv, len);
5050     char *strend = s + len;
5051     register PMOP *pm;
5052     register REGEXP *rx;
5053     register SV *dstr;
5054     register char *m;
5055     I32 iters = 0;
5056     I32 maxiters = (strend - s) + 10;
5057     I32 i;
5058     char *orig;
5059     I32 origlimit = limit;
5060     I32 realarray = 0;
5061     I32 base;
5062     AV *oldstack = PL_curstack;
5063     I32 gimme = GIMME_V;
5064     I32 oldsave = PL_savestack_ix;
5065     I32 make_mortal = 1;
5066     MAGIC *mg = (MAGIC *) NULL;
5067
5068 #ifdef DEBUGGING
5069     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5070 #else
5071     pm = (PMOP*)POPs;
5072 #endif
5073     if (!pm || !s)
5074         DIE(aTHX_ "panic: do_split");
5075     rx = pm->op_pmregexp;
5076
5077     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5078              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5079
5080     if (pm->op_pmreplroot) {
5081 #ifdef USE_ITHREADS
5082         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5083 #else
5084         ary = GvAVn((GV*)pm->op_pmreplroot);
5085 #endif
5086     }
5087     else if (gimme != G_ARRAY)
5088 #ifdef USE_THREADS
5089         ary = (AV*)PL_curpad[0];
5090 #else
5091         ary = GvAVn(PL_defgv);
5092 #endif /* USE_THREADS */
5093     else
5094         ary = Nullav;
5095     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5096         realarray = 1;
5097         PUTBACK;
5098         av_extend(ary,0);
5099         av_clear(ary);
5100         SPAGAIN;
5101         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5102             PUSHMARK(SP);
5103             XPUSHs(SvTIED_obj((SV*)ary, mg));
5104         }
5105         else {
5106             if (!AvREAL(ary)) {
5107                 AvREAL_on(ary);
5108                 AvREIFY_off(ary);
5109                 for (i = AvFILLp(ary); i >= 0; i--)
5110                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5111             }
5112             /* temporarily switch stacks */
5113             SWITCHSTACK(PL_curstack, ary);
5114             make_mortal = 0;
5115         }
5116     }
5117     base = SP - PL_stack_base;
5118     orig = s;
5119     if (pm->op_pmflags & PMf_SKIPWHITE) {
5120         if (pm->op_pmflags & PMf_LOCALE) {
5121             while (isSPACE_LC(*s))
5122                 s++;
5123         }
5124         else {
5125             while (isSPACE(*s))
5126                 s++;
5127         }
5128     }
5129     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5130         SAVEINT(PL_multiline);
5131         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5132     }
5133
5134     if (!limit)
5135         limit = maxiters + 2;
5136     if (pm->op_pmflags & PMf_WHITE) {
5137         while (--limit) {
5138             m = s;
5139             while (m < strend &&
5140                    !((pm->op_pmflags & PMf_LOCALE)
5141                      ? isSPACE_LC(*m) : isSPACE(*m)))
5142                 ++m;
5143             if (m >= strend)
5144                 break;
5145
5146             dstr = NEWSV(30, m-s);
5147             sv_setpvn(dstr, s, m-s);
5148             if (make_mortal)
5149                 sv_2mortal(dstr);
5150             if (doutf8)
5151                 (void)SvUTF8_on(dstr);
5152             XPUSHs(dstr);
5153
5154             s = m + 1;
5155             while (s < strend &&
5156                    ((pm->op_pmflags & PMf_LOCALE)
5157                     ? isSPACE_LC(*s) : isSPACE(*s)))
5158                 ++s;
5159         }
5160     }
5161     else if (strEQ("^", rx->precomp)) {
5162         while (--limit) {
5163             /*SUPPRESS 530*/
5164             for (m = s; m < strend && *m != '\n'; m++) ;
5165             m++;
5166             if (m >= strend)
5167                 break;
5168             dstr = NEWSV(30, m-s);
5169             sv_setpvn(dstr, s, m-s);
5170             if (make_mortal)
5171                 sv_2mortal(dstr);
5172             if (doutf8)
5173                 (void)SvUTF8_on(dstr);
5174             XPUSHs(dstr);
5175             s = m;
5176         }
5177     }
5178     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5179              && (rx->reganch & ROPT_CHECK_ALL)
5180              && !(rx->reganch & ROPT_ANCH)) {
5181         int tail = (rx->reganch & RE_INTUIT_TAIL);
5182         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5183
5184         len = rx->minlen;
5185         if (len == 1 && !tail) {
5186             STRLEN n_a;
5187             char c = *SvPV(csv, n_a);
5188             while (--limit) {
5189                 /*SUPPRESS 530*/
5190                 for (m = s; m < strend && *m != c; m++) ;
5191                 if (m >= strend)
5192                     break;
5193                 dstr = NEWSV(30, m-s);
5194                 sv_setpvn(dstr, s, m-s);
5195                 if (make_mortal)
5196                     sv_2mortal(dstr);
5197                 if (doutf8)
5198                     (void)SvUTF8_on(dstr);
5199                 XPUSHs(dstr);
5200                 /* The rx->minlen is in characters but we want to step
5201                  * s ahead by bytes. */
5202                 s = m + (doutf8 ? SvCUR(csv) : len);
5203             }
5204         }
5205         else {
5206 #ifndef lint
5207             while (s < strend && --limit &&
5208               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5209                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5210 #endif
5211             {
5212                 dstr = NEWSV(31, m-s);
5213                 sv_setpvn(dstr, s, m-s);
5214                 if (make_mortal)
5215                     sv_2mortal(dstr);
5216                 if (doutf8)
5217                     (void)SvUTF8_on(dstr);
5218                 XPUSHs(dstr);
5219                 /* The rx->minlen is in characters but we want to step
5220                  * s ahead by bytes. */
5221                 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5222             }
5223         }
5224     }
5225     else {
5226         maxiters += (strend - s) * rx->nparens;
5227         while (s < strend && --limit
5228 /*             && (!rx->check_substr
5229                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5230                                                  0, NULL))))
5231 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5232                               1 /* minend */, sv, NULL, 0))
5233         {
5234             TAINT_IF(RX_MATCH_TAINTED(rx));
5235             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5236                 m = s;
5237                 s = orig;
5238                 orig = rx->subbeg;
5239                 s = orig + (m - s);
5240                 strend = s + (strend - m);
5241             }
5242             m = rx->startp[0] + orig;
5243             dstr = NEWSV(32, m-s);
5244             sv_setpvn(dstr, s, m-s);
5245             if (make_mortal)
5246                 sv_2mortal(dstr);
5247             if (doutf8)
5248                 (void)SvUTF8_on(dstr);
5249             XPUSHs(dstr);
5250             if (rx->nparens) {
5251                 for (i = 1; i <= rx->nparens; i++) {
5252                     s = rx->startp[i] + orig;
5253                     m = rx->endp[i] + orig;
5254                     if (m && s) {
5255                         dstr = NEWSV(33, m-s);
5256                         sv_setpvn(dstr, s, m-s);
5257                     }
5258                     else
5259                         dstr = NEWSV(33, 0);
5260                     if (make_mortal)
5261                         sv_2mortal(dstr);
5262                     if (doutf8)
5263                         (void)SvUTF8_on(dstr);
5264                     XPUSHs(dstr);
5265                 }
5266             }
5267             s = rx->endp[0] + orig;
5268         }
5269     }
5270
5271     LEAVE_SCOPE(oldsave);
5272     iters = (SP - PL_stack_base) - base;
5273     if (iters > maxiters)
5274         DIE(aTHX_ "Split loop");
5275
5276     /* keep field after final delim? */
5277     if (s < strend || (iters && origlimit)) {
5278         STRLEN l = strend - s;
5279         dstr = NEWSV(34, l);
5280         sv_setpvn(dstr, s, l);
5281         if (make_mortal)
5282             sv_2mortal(dstr);
5283         if (doutf8)
5284             (void)SvUTF8_on(dstr);
5285         XPUSHs(dstr);
5286         iters++;
5287     }
5288     else if (!origlimit) {
5289         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5290             iters--, SP--;
5291     }
5292
5293     if (realarray) {
5294         if (!mg) {
5295             SWITCHSTACK(ary, oldstack);
5296             if (SvSMAGICAL(ary)) {
5297                 PUTBACK;
5298                 mg_set((SV*)ary);
5299                 SPAGAIN;
5300             }
5301             if (gimme == G_ARRAY) {
5302                 EXTEND(SP, iters);
5303                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5304                 SP += iters;
5305                 RETURN;
5306             }
5307         }
5308         else {
5309             PUTBACK;
5310             ENTER;
5311             call_method("PUSH",G_SCALAR|G_DISCARD);
5312             LEAVE;
5313             SPAGAIN;
5314             if (gimme == G_ARRAY) {
5315                 /* EXTEND should not be needed - we just popped them */
5316                 EXTEND(SP, iters);
5317                 for (i=0; i < iters; i++) {
5318                     SV **svp = av_fetch(ary, i, FALSE);
5319                     PUSHs((svp) ? *svp : &PL_sv_undef);
5320                 }
5321                 RETURN;
5322             }
5323         }
5324     }
5325     else {
5326         if (gimme == G_ARRAY)
5327             RETURN;
5328     }
5329     if (iters || !pm->op_pmreplroot) {
5330         GETTARGET;
5331         PUSHi(iters);
5332         RETURN;
5333     }
5334     RETPUSHUNDEF;
5335 }
5336
5337 #ifdef USE_THREADS
5338 void
5339 Perl_unlock_condpair(pTHX_ void *svv)
5340 {
5341     dTHR;
5342     MAGIC *mg = mg_find((SV*)svv, 'm');
5343
5344     if (!mg)
5345         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5346     MUTEX_LOCK(MgMUTEXP(mg));
5347     if (MgOWNER(mg) != thr)
5348         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5349     MgOWNER(mg) = 0;
5350     COND_SIGNAL(MgOWNERCONDP(mg));
5351     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5352                           PTR2UV(thr), PTR2UV(svv));)
5353     MUTEX_UNLOCK(MgMUTEXP(mg));
5354 }
5355 #endif /* USE_THREADS */
5356
5357 PP(pp_lock)
5358 {
5359     djSP;
5360     dTOPss;
5361     SV *retsv = sv;
5362 #ifdef USE_THREADS
5363     sv_lock(sv);
5364 #endif /* USE_THREADS */
5365     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5366         || SvTYPE(retsv) == SVt_PVCV) {
5367         retsv = refto(retsv);
5368     }
5369     SETs(retsv);
5370     RETURN;
5371 }
5372
5373 PP(pp_threadsv)
5374 {
5375 #ifdef USE_THREADS
5376     djSP;
5377     EXTEND(SP, 1);
5378     if (PL_op->op_private & OPpLVAL_INTRO)
5379         PUSHs(*save_threadsv(PL_op->op_targ));
5380     else
5381         PUSHs(THREADSV(PL_op->op_targ));
5382     RETURN;
5383 #else
5384     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5385 #endif /* USE_THREADS */
5386 }