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