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