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           I32 l;
1484
1485           send = tmps + len;
1486           while (tmps < send) {
1487             UV c = utf8_to_uv(tmps, &l);
1488             tmps += UTF8SKIP(tmps);
1489             targlen += UTF8LEN(~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, &l);
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;
1570       SETi( left + right );
1571       RETURN;
1572     }
1573 }
1574
1575 PP(pp_i_subtract)
1576 {
1577     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1578     {
1579       dPOPTOPiirl;
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     I32 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     I32 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     STRLEN n_a;
2238     SV *tmpsv = POPs;
2239     U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2240     I32 retlen;
2241
2242     if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2243         value = utf8_to_uv_chk(tmps, &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         I32 ulen;
2308         U8 tmpbuf[UTF8_MAXLEN];
2309         U8 *tend;
2310         UV uv = utf8_to_uv_chk(s, &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         I32 ulen;
2367         U8 tmpbuf[UTF8_MAXLEN];
2368         U8 *tend;
2369         UV uv = utf8_to_uv_chk(s, &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         I32 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_chk(s, &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         I32 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_chk(s, &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     I16 ashort;
3365     int aint;
3366     I32 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                     auint = utf8_to_uv_chk((U8*)s, &along, 0);
3663                     s += along;
3664                     if (checksum > 32)
3665                         cdouble += (NV)auint;
3666                     else
3667                         culong += auint;
3668                 }
3669             }
3670             else {
3671                 EXTEND(SP, len);
3672                 EXTEND_MORTAL(len);
3673                 while (len-- > 0 && s < strend) {
3674                     auint = utf8_to_uv_chk((U8*)s, &along, 0);
3675                     s += along;
3676                     sv = NEWSV(37, 0);
3677                     sv_setuv(sv, (UV)auint);
3678                     PUSHs(sv_2mortal(sv));
3679                 }
3680             }
3681             break;
3682         case 's':
3683 #if SHORTSIZE == SIZE16
3684             along = (strend - s) / SIZE16;
3685 #else
3686             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3687 #endif
3688             if (len > along)
3689                 len = along;
3690             if (checksum) {
3691 #if SHORTSIZE != SIZE16
3692                 if (natint) {
3693                     short ashort;
3694                     while (len-- > 0) {
3695                         COPYNN(s, &ashort, sizeof(short));
3696                         s += sizeof(short);
3697                         culong += ashort;
3698
3699                     }
3700                 }
3701                 else
3702 #endif
3703                 {
3704                     while (len-- > 0) {
3705                         COPY16(s, &ashort);
3706 #if SHORTSIZE > SIZE16
3707                         if (ashort > 32767)
3708                           ashort -= 65536;
3709 #endif
3710                         s += SIZE16;
3711                         culong += ashort;
3712                     }
3713                 }
3714             }
3715             else {
3716                 EXTEND(SP, len);
3717                 EXTEND_MORTAL(len);
3718 #if SHORTSIZE != SIZE16
3719                 if (natint) {
3720                     short ashort;
3721                     while (len-- > 0) {
3722                         COPYNN(s, &ashort, sizeof(short));
3723                         s += sizeof(short);
3724                         sv = NEWSV(38, 0);
3725                         sv_setiv(sv, (IV)ashort);
3726                         PUSHs(sv_2mortal(sv));
3727                     }
3728                 }
3729                 else
3730 #endif
3731                 {
3732                     while (len-- > 0) {
3733                         COPY16(s, &ashort);
3734 #if SHORTSIZE > SIZE16
3735                         if (ashort > 32767)
3736                           ashort -= 65536;
3737 #endif
3738                         s += SIZE16;
3739                         sv = NEWSV(38, 0);
3740                         sv_setiv(sv, (IV)ashort);
3741                         PUSHs(sv_2mortal(sv));
3742                     }
3743                 }
3744             }
3745             break;
3746         case 'v':
3747         case 'n':
3748         case 'S':
3749 #if SHORTSIZE == SIZE16
3750             along = (strend - s) / SIZE16;
3751 #else
3752             unatint = natint && datumtype == 'S';
3753             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3754 #endif
3755             if (len > along)
3756                 len = along;
3757             if (checksum) {
3758 #if SHORTSIZE != SIZE16
3759                 if (unatint) {
3760                     unsigned short aushort;
3761                     while (len-- > 0) {
3762                         COPYNN(s, &aushort, sizeof(unsigned short));
3763                         s += sizeof(unsigned short);
3764                         culong += aushort;
3765                     }
3766                 }
3767                 else
3768 #endif
3769                 {
3770                     while (len-- > 0) {
3771                         COPY16(s, &aushort);
3772                         s += SIZE16;
3773 #ifdef HAS_NTOHS
3774                         if (datumtype == 'n')
3775                             aushort = PerlSock_ntohs(aushort);
3776 #endif
3777 #ifdef HAS_VTOHS
3778                         if (datumtype == 'v')
3779                             aushort = vtohs(aushort);
3780 #endif
3781                         culong += aushort;
3782                     }
3783                 }
3784             }
3785             else {
3786                 EXTEND(SP, len);
3787                 EXTEND_MORTAL(len);
3788 #if SHORTSIZE != SIZE16
3789                 if (unatint) {
3790                     unsigned short aushort;
3791                     while (len-- > 0) {
3792                         COPYNN(s, &aushort, sizeof(unsigned short));
3793                         s += sizeof(unsigned short);
3794                         sv = NEWSV(39, 0);
3795                         sv_setiv(sv, (UV)aushort);
3796                         PUSHs(sv_2mortal(sv));
3797                     }
3798                 }
3799                 else
3800 #endif
3801                 {
3802                     while (len-- > 0) {
3803                         COPY16(s, &aushort);
3804                         s += SIZE16;
3805                         sv = NEWSV(39, 0);
3806 #ifdef HAS_NTOHS
3807                         if (datumtype == 'n')
3808                             aushort = PerlSock_ntohs(aushort);
3809 #endif
3810 #ifdef HAS_VTOHS
3811                         if (datumtype == 'v')
3812                             aushort = vtohs(aushort);
3813 #endif
3814                         sv_setiv(sv, (UV)aushort);
3815                         PUSHs(sv_2mortal(sv));
3816                     }
3817                 }
3818             }
3819             break;
3820         case 'i':
3821             along = (strend - s) / sizeof(int);
3822             if (len > along)
3823                 len = along;
3824             if (checksum) {
3825                 while (len-- > 0) {
3826                     Copy(s, &aint, 1, int);
3827                     s += sizeof(int);
3828                     if (checksum > 32)
3829                         cdouble += (NV)aint;
3830                     else
3831                         culong += aint;
3832                 }
3833             }
3834             else {
3835                 EXTEND(SP, len);
3836                 EXTEND_MORTAL(len);
3837                 while (len-- > 0) {
3838                     Copy(s, &aint, 1, int);
3839                     s += sizeof(int);
3840                     sv = NEWSV(40, 0);
3841 #ifdef __osf__
3842                     /* Without the dummy below unpack("i", pack("i",-1))
3843                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3844                      * cc with optimization turned on.
3845                      *
3846                      * The bug was detected in
3847                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3848                      * with optimization (-O4) turned on.
3849                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3850                      * does not have this problem even with -O4.
3851                      *
3852                      * This bug was reported as DECC_BUGS 1431
3853                      * and tracked internally as GEM_BUGS 7775.
3854                      *
3855                      * The bug is fixed in
3856                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3857                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3858                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3859                      * and also in DTK.
3860                      *
3861                      * See also few lines later for the same bug.
3862                      */
3863                     (aint) ?
3864                         sv_setiv(sv, (IV)aint) :
3865 #endif
3866                     sv_setiv(sv, (IV)aint);
3867                     PUSHs(sv_2mortal(sv));
3868                 }
3869             }
3870             break;
3871         case 'I':
3872             along = (strend - s) / sizeof(unsigned int);
3873             if (len > along)
3874                 len = along;
3875             if (checksum) {
3876                 while (len-- > 0) {
3877                     Copy(s, &auint, 1, unsigned int);
3878                     s += sizeof(unsigned int);
3879                     if (checksum > 32)
3880                         cdouble += (NV)auint;
3881                     else
3882                         culong += auint;
3883                 }
3884             }
3885             else {
3886                 EXTEND(SP, len);
3887                 EXTEND_MORTAL(len);
3888                 while (len-- > 0) {
3889                     Copy(s, &auint, 1, unsigned int);
3890                     s += sizeof(unsigned int);
3891                     sv = NEWSV(41, 0);
3892 #ifdef __osf__
3893                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3894                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3895                      * See details few lines earlier. */
3896                     (auint) ?
3897                         sv_setuv(sv, (UV)auint) :
3898 #endif
3899                     sv_setuv(sv, (UV)auint);
3900                     PUSHs(sv_2mortal(sv));
3901                 }
3902             }
3903             break;
3904         case 'l':
3905 #if LONGSIZE == SIZE32
3906             along = (strend - s) / SIZE32;
3907 #else
3908             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3909 #endif
3910             if (len > along)
3911                 len = along;
3912             if (checksum) {
3913 #if LONGSIZE != SIZE32
3914                 if (natint) {
3915                     long along;
3916                     while (len-- > 0) {
3917                         COPYNN(s, &along, sizeof(long));
3918                         s += sizeof(long);
3919                         if (checksum > 32)
3920                             cdouble += (NV)along;
3921                         else
3922                             culong += along;
3923                     }
3924                 }
3925                 else
3926 #endif
3927                 {
3928                     while (len-- > 0) {
3929                         COPY32(s, &along);
3930 #if LONGSIZE > SIZE32
3931                         if (along > 2147483647)
3932                           along -= 4294967296;
3933 #endif
3934                         s += SIZE32;
3935                         if (checksum > 32)
3936                             cdouble += (NV)along;
3937                         else
3938                             culong += along;
3939                     }
3940                 }
3941             }
3942             else {
3943                 EXTEND(SP, len);
3944                 EXTEND_MORTAL(len);
3945 #if LONGSIZE != SIZE32
3946                 if (natint) {
3947                     long along;
3948                     while (len-- > 0) {
3949                         COPYNN(s, &along, sizeof(long));
3950                         s += sizeof(long);
3951                         sv = NEWSV(42, 0);
3952                         sv_setiv(sv, (IV)along);
3953                         PUSHs(sv_2mortal(sv));
3954                     }
3955                 }
3956                 else
3957 #endif
3958                 {
3959                     while (len-- > 0) {
3960                         COPY32(s, &along);
3961 #if LONGSIZE > SIZE32
3962                         if (along > 2147483647)
3963                           along -= 4294967296;
3964 #endif
3965                         s += SIZE32;
3966                         sv = NEWSV(42, 0);
3967                         sv_setiv(sv, (IV)along);
3968                         PUSHs(sv_2mortal(sv));
3969                     }
3970                 }
3971             }
3972             break;
3973         case 'V':
3974         case 'N':
3975         case 'L':
3976 #if LONGSIZE == SIZE32
3977             along = (strend - s) / SIZE32;
3978 #else
3979             unatint = natint && datumtype == 'L';
3980             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3981 #endif
3982             if (len > along)
3983                 len = along;
3984             if (checksum) {
3985 #if LONGSIZE != SIZE32
3986                 if (unatint) {
3987                     unsigned long aulong;
3988                     while (len-- > 0) {
3989                         COPYNN(s, &aulong, sizeof(unsigned long));
3990                         s += sizeof(unsigned long);
3991                         if (checksum > 32)
3992                             cdouble += (NV)aulong;
3993                         else
3994                             culong += aulong;
3995                     }
3996                 }
3997                 else
3998 #endif
3999                 {
4000                     while (len-- > 0) {
4001                         COPY32(s, &aulong);
4002                         s += SIZE32;
4003 #ifdef HAS_NTOHL
4004                         if (datumtype == 'N')
4005                             aulong = PerlSock_ntohl(aulong);
4006 #endif
4007 #ifdef HAS_VTOHL
4008                         if (datumtype == 'V')
4009                             aulong = vtohl(aulong);
4010 #endif
4011                         if (checksum > 32)
4012                             cdouble += (NV)aulong;
4013                         else
4014                             culong += aulong;
4015                     }
4016                 }
4017             }
4018             else {
4019                 EXTEND(SP, len);
4020                 EXTEND_MORTAL(len);
4021 #if LONGSIZE != SIZE32
4022                 if (unatint) {
4023                     unsigned long aulong;
4024                     while (len-- > 0) {
4025                         COPYNN(s, &aulong, sizeof(unsigned long));
4026                         s += sizeof(unsigned long);
4027                         sv = NEWSV(43, 0);
4028                         sv_setuv(sv, (UV)aulong);
4029                         PUSHs(sv_2mortal(sv));
4030                     }
4031                 }
4032                 else
4033 #endif
4034                 {
4035                     while (len-- > 0) {
4036                         COPY32(s, &aulong);
4037                         s += SIZE32;
4038 #ifdef HAS_NTOHL
4039                         if (datumtype == 'N')
4040                             aulong = PerlSock_ntohl(aulong);
4041 #endif
4042 #ifdef HAS_VTOHL
4043                         if (datumtype == 'V')
4044                             aulong = vtohl(aulong);
4045 #endif
4046                         sv = NEWSV(43, 0);
4047                         sv_setuv(sv, (UV)aulong);
4048                         PUSHs(sv_2mortal(sv));
4049                     }
4050                 }
4051             }
4052             break;
4053         case 'p':
4054             along = (strend - s) / sizeof(char*);
4055             if (len > along)
4056                 len = along;
4057             EXTEND(SP, len);
4058             EXTEND_MORTAL(len);
4059             while (len-- > 0) {
4060                 if (sizeof(char*) > strend - s)
4061                     break;
4062                 else {
4063                     Copy(s, &aptr, 1, char*);
4064                     s += sizeof(char*);
4065                 }
4066                 sv = NEWSV(44, 0);
4067                 if (aptr)
4068                     sv_setpv(sv, aptr);
4069                 PUSHs(sv_2mortal(sv));
4070             }
4071             break;
4072         case 'w':
4073             EXTEND(SP, len);
4074             EXTEND_MORTAL(len);
4075             {
4076                 UV auv = 0;
4077                 U32 bytes = 0;
4078
4079                 while ((len > 0) && (s < strend)) {
4080                     auv = (auv << 7) | (*s & 0x7f);
4081                     if (!(*s++ & 0x80)) {
4082                         bytes = 0;
4083                         sv = NEWSV(40, 0);
4084                         sv_setuv(sv, auv);
4085                         PUSHs(sv_2mortal(sv));
4086                         len--;
4087                         auv = 0;
4088                     }
4089                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
4090                         char *t;
4091                         STRLEN n_a;
4092
4093                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4094                         while (s < strend) {
4095                             sv = mul128(sv, *s & 0x7f);
4096                             if (!(*s++ & 0x80)) {
4097                                 bytes = 0;
4098                                 break;
4099                             }
4100                         }
4101                         t = SvPV(sv, n_a);
4102                         while (*t == '0')
4103                             t++;
4104                         sv_chop(sv, t);
4105                         PUSHs(sv_2mortal(sv));
4106                         len--;
4107                         auv = 0;
4108                     }
4109                 }
4110                 if ((s >= strend) && bytes)
4111                     DIE(aTHX_ "Unterminated compressed integer");
4112             }
4113             break;
4114         case 'P':
4115             EXTEND(SP, 1);
4116             if (sizeof(char*) > strend - s)
4117                 break;
4118             else {
4119                 Copy(s, &aptr, 1, char*);
4120                 s += sizeof(char*);
4121             }
4122             sv = NEWSV(44, 0);
4123             if (aptr)
4124                 sv_setpvn(sv, aptr, len);
4125             PUSHs(sv_2mortal(sv));
4126             break;
4127 #ifdef HAS_QUAD
4128         case 'q':
4129             along = (strend - s) / sizeof(Quad_t);
4130             if (len > along)
4131                 len = along;
4132             EXTEND(SP, len);
4133             EXTEND_MORTAL(len);
4134             while (len-- > 0) {
4135                 if (s + sizeof(Quad_t) > strend)
4136                     aquad = 0;
4137                 else {
4138                     Copy(s, &aquad, 1, Quad_t);
4139                     s += sizeof(Quad_t);
4140                 }
4141                 sv = NEWSV(42, 0);
4142                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4143                     sv_setiv(sv, (IV)aquad);
4144                 else
4145                     sv_setnv(sv, (NV)aquad);
4146                 PUSHs(sv_2mortal(sv));
4147             }
4148             break;
4149         case 'Q':
4150             along = (strend - s) / sizeof(Quad_t);
4151             if (len > along)
4152                 len = along;
4153             EXTEND(SP, len);
4154             EXTEND_MORTAL(len);
4155             while (len-- > 0) {
4156                 if (s + sizeof(Uquad_t) > strend)
4157                     auquad = 0;
4158                 else {
4159                     Copy(s, &auquad, 1, Uquad_t);
4160                     s += sizeof(Uquad_t);
4161                 }
4162                 sv = NEWSV(43, 0);
4163                 if (auquad <= UV_MAX)
4164                     sv_setuv(sv, (UV)auquad);
4165                 else
4166                     sv_setnv(sv, (NV)auquad);
4167                 PUSHs(sv_2mortal(sv));
4168             }
4169             break;
4170 #endif
4171         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4172         case 'f':
4173         case 'F':
4174             along = (strend - s) / sizeof(float);
4175             if (len > along)
4176                 len = along;
4177             if (checksum) {
4178                 while (len-- > 0) {
4179                     Copy(s, &afloat, 1, float);
4180                     s += sizeof(float);
4181                     cdouble += afloat;
4182                 }
4183             }
4184             else {
4185                 EXTEND(SP, len);
4186                 EXTEND_MORTAL(len);
4187                 while (len-- > 0) {
4188                     Copy(s, &afloat, 1, float);
4189                     s += sizeof(float);
4190                     sv = NEWSV(47, 0);
4191                     sv_setnv(sv, (NV)afloat);
4192                     PUSHs(sv_2mortal(sv));
4193                 }
4194             }
4195             break;
4196         case 'd':
4197         case 'D':
4198             along = (strend - s) / sizeof(double);
4199             if (len > along)
4200                 len = along;
4201             if (checksum) {
4202                 while (len-- > 0) {
4203                     Copy(s, &adouble, 1, double);
4204                     s += sizeof(double);
4205                     cdouble += adouble;
4206                 }
4207             }
4208             else {
4209                 EXTEND(SP, len);
4210                 EXTEND_MORTAL(len);
4211                 while (len-- > 0) {
4212                     Copy(s, &adouble, 1, double);
4213                     s += sizeof(double);
4214                     sv = NEWSV(48, 0);
4215                     sv_setnv(sv, (NV)adouble);
4216                     PUSHs(sv_2mortal(sv));
4217                 }
4218             }
4219             break;
4220         case 'u':
4221             /* MKS:
4222              * Initialise the decode mapping.  By using a table driven
4223              * algorithm, the code will be character-set independent
4224              * (and just as fast as doing character arithmetic)
4225              */
4226             if (PL_uudmap['M'] == 0) {
4227                 int i;
4228
4229                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4230                     PL_uudmap[(U8)PL_uuemap[i]] = i;
4231                 /*
4232                  * Because ' ' and '`' map to the same value,
4233                  * we need to decode them both the same.
4234                  */
4235                 PL_uudmap[' '] = 0;
4236             }
4237
4238             along = (strend - s) * 3 / 4;
4239             sv = NEWSV(42, along);
4240             if (along)
4241                 SvPOK_on(sv);
4242             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4243                 I32 a, b, c, d;
4244                 char hunk[4];
4245
4246                 hunk[3] = '\0';
4247                 len = PL_uudmap[*(U8*)s++] & 077;
4248                 while (len > 0) {
4249                     if (s < strend && ISUUCHAR(*s))
4250                         a = PL_uudmap[*(U8*)s++] & 077;
4251                     else
4252                         a = 0;
4253                     if (s < strend && ISUUCHAR(*s))
4254                         b = PL_uudmap[*(U8*)s++] & 077;
4255                     else
4256                         b = 0;
4257                     if (s < strend && ISUUCHAR(*s))
4258                         c = PL_uudmap[*(U8*)s++] & 077;
4259                     else
4260                         c = 0;
4261                     if (s < strend && ISUUCHAR(*s))
4262                         d = PL_uudmap[*(U8*)s++] & 077;
4263                     else
4264                         d = 0;
4265                     hunk[0] = (a << 2) | (b >> 4);
4266                     hunk[1] = (b << 4) | (c >> 2);
4267                     hunk[2] = (c << 6) | d;
4268                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4269                     len -= 3;
4270                 }
4271                 if (*s == '\n')
4272                     s++;
4273                 else if (s[1] == '\n')          /* possible checksum byte */
4274                     s += 2;
4275             }
4276             XPUSHs(sv_2mortal(sv));
4277             break;
4278         }
4279         if (checksum) {
4280             sv = NEWSV(42, 0);
4281             if (strchr("fFdD", datumtype) ||
4282               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4283                 NV trouble;
4284
4285                 adouble = 1.0;
4286                 while (checksum >= 16) {
4287                     checksum -= 16;
4288                     adouble *= 65536.0;
4289                 }
4290                 while (checksum >= 4) {
4291                     checksum -= 4;
4292                     adouble *= 16.0;
4293                 }
4294                 while (checksum--)
4295                     adouble *= 2.0;
4296                 along = (1 << checksum) - 1;
4297                 while (cdouble < 0.0)
4298                     cdouble += adouble;
4299                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4300                 sv_setnv(sv, cdouble);
4301             }
4302             else {
4303                 if (checksum < 32) {
4304                     aulong = (1 << checksum) - 1;
4305                     culong &= aulong;
4306                 }
4307                 sv_setuv(sv, (UV)culong);
4308             }
4309             XPUSHs(sv_2mortal(sv));
4310             checksum = 0;
4311         }
4312     }
4313     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4314         PUSHs(&PL_sv_undef);
4315     RETURN;
4316 }
4317
4318 STATIC void
4319 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4320 {
4321     char hunk[5];
4322
4323     *hunk = PL_uuemap[len];
4324     sv_catpvn(sv, hunk, 1);
4325     hunk[4] = '\0';
4326     while (len > 2) {
4327         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4328         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4329         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4330         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4331         sv_catpvn(sv, hunk, 4);
4332         s += 3;
4333         len -= 3;
4334     }
4335     if (len > 0) {
4336         char r = (len > 1 ? s[1] : '\0');
4337         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4338         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4339         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4340         hunk[3] = PL_uuemap[0];
4341         sv_catpvn(sv, hunk, 4);
4342     }
4343     sv_catpvn(sv, "\n", 1);
4344 }
4345
4346 STATIC SV *
4347 S_is_an_int(pTHX_ char *s, STRLEN l)
4348 {
4349   STRLEN         n_a;
4350   SV             *result = newSVpvn(s, l);
4351   char           *result_c = SvPV(result, n_a); /* convenience */
4352   char           *out = result_c;
4353   bool            skip = 1;
4354   bool            ignore = 0;
4355
4356   while (*s) {
4357     switch (*s) {
4358     case ' ':
4359       break;
4360     case '+':
4361       if (!skip) {
4362         SvREFCNT_dec(result);
4363         return (NULL);
4364       }
4365       break;
4366     case '0':
4367     case '1':
4368     case '2':
4369     case '3':
4370     case '4':
4371     case '5':
4372     case '6':
4373     case '7':
4374     case '8':
4375     case '9':
4376       skip = 0;
4377       if (!ignore) {
4378         *(out++) = *s;
4379       }
4380       break;
4381     case '.':
4382       ignore = 1;
4383       break;
4384     default:
4385       SvREFCNT_dec(result);
4386       return (NULL);
4387     }
4388     s++;
4389   }
4390   *(out++) = '\0';
4391   SvCUR_set(result, out - result_c);
4392   return (result);
4393 }
4394
4395 /* pnum must be '\0' terminated */
4396 STATIC int
4397 S_div128(pTHX_ SV *pnum, bool *done)
4398 {
4399   STRLEN          len;
4400   char           *s = SvPV(pnum, len);
4401   int             m = 0;
4402   int             r = 0;
4403   char           *t = s;
4404
4405   *done = 1;
4406   while (*t) {
4407     int             i;
4408
4409     i = m * 10 + (*t - '0');
4410     m = i & 0x7F;
4411     r = (i >> 7);               /* r < 10 */
4412     if (r) {
4413       *done = 0;
4414     }
4415     *(t++) = '0' + r;
4416   }
4417   *(t++) = '\0';
4418   SvCUR_set(pnum, (STRLEN) (t - s));
4419   return (m);
4420 }
4421
4422
4423 PP(pp_pack)
4424 {
4425     djSP; dMARK; dORIGMARK; dTARGET;
4426     register SV *cat = TARG;
4427     register I32 items;
4428     STRLEN fromlen;
4429     register char *pat = SvPVx(*++MARK, fromlen);
4430     char *patcopy;
4431     register char *patend = pat + fromlen;
4432     register I32 len;
4433     I32 datumtype;
4434     SV *fromstr;
4435     /*SUPPRESS 442*/
4436     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4437     static char *space10 = "          ";
4438
4439     /* These must not be in registers: */
4440     char achar;
4441     I16 ashort;
4442     int aint;
4443     unsigned int auint;
4444     I32 along;
4445     U32 aulong;
4446 #ifdef HAS_QUAD
4447     Quad_t aquad;
4448     Uquad_t auquad;
4449 #endif
4450     char *aptr;
4451     float afloat;
4452     double adouble;
4453     int commas = 0;
4454 #ifdef PERL_NATINT_PACK
4455     int natint;         /* native integer */
4456 #endif
4457
4458     items = SP - MARK;
4459     MARK++;
4460     sv_setpvn(cat, "", 0);
4461     patcopy = pat;
4462     while (pat < patend) {
4463         SV *lengthcode = Nullsv;
4464 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4465         datumtype = *pat++ & 0xFF;
4466 #ifdef PERL_NATINT_PACK
4467         natint = 0;
4468 #endif
4469         if (isSPACE(datumtype)) {
4470             patcopy++;
4471             continue;
4472         }
4473         if (datumtype == 'U' && pat == patcopy+1)
4474             SvUTF8_on(cat);
4475         if (datumtype == '#') {
4476             while (pat < patend && *pat != '\n')
4477                 pat++;
4478             continue;
4479         }
4480         if (*pat == '!') {
4481             char *natstr = "sSiIlL";
4482
4483             if (strchr(natstr, datumtype)) {
4484 #ifdef PERL_NATINT_PACK
4485                 natint = 1;
4486 #endif
4487                 pat++;
4488             }
4489             else
4490                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4491         }
4492         if (*pat == '*') {
4493             len = strchr("@Xxu", datumtype) ? 0 : items;
4494             pat++;
4495         }
4496         else if (isDIGIT(*pat)) {
4497             len = *pat++ - '0';
4498             while (isDIGIT(*pat)) {
4499                 len = (len * 10) + (*pat++ - '0');
4500                 if (len < 0)
4501                     DIE(aTHX_ "Repeat count in pack overflows");
4502             }
4503         }
4504         else
4505             len = 1;
4506         if (*pat == '/') {
4507             ++pat;
4508             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4509                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4510             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4511                                                    ? *MARK : &PL_sv_no)
4512                                             + (*pat == 'Z' ? 1 : 0)));
4513         }
4514         switch(datumtype) {
4515         default:
4516             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4517         case ',': /* grandfather in commas but with a warning */
4518             if (commas++ == 0 && ckWARN(WARN_PACK))
4519                 Perl_warner(aTHX_ WARN_PACK,
4520                             "Invalid type in pack: '%c'", (int)datumtype);
4521             break;
4522         case '%':
4523             DIE(aTHX_ "%% may only be used in unpack");
4524         case '@':
4525             len -= SvCUR(cat);
4526             if (len > 0)
4527                 goto grow;
4528             len = -len;
4529             if (len > 0)
4530                 goto shrink;
4531             break;
4532         case 'X':
4533           shrink:
4534             if (SvCUR(cat) < len)
4535                 DIE(aTHX_ "X outside of string");
4536             SvCUR(cat) -= len;
4537             *SvEND(cat) = '\0';
4538             break;
4539         case 'x':
4540           grow:
4541             while (len >= 10) {
4542                 sv_catpvn(cat, null10, 10);
4543                 len -= 10;
4544             }
4545             sv_catpvn(cat, null10, len);
4546             break;
4547         case 'A':
4548         case 'Z':
4549         case 'a':
4550             fromstr = NEXTFROM;
4551             aptr = SvPV(fromstr, fromlen);
4552             if (pat[-1] == '*') {
4553                 len = fromlen;
4554                 if (datumtype == 'Z')
4555                     ++len;
4556             }
4557             if (fromlen >= len) {
4558                 sv_catpvn(cat, aptr, len);
4559                 if (datumtype == 'Z')
4560                     *(SvEND(cat)-1) = '\0';
4561             }
4562             else {
4563                 sv_catpvn(cat, aptr, fromlen);
4564                 len -= fromlen;
4565                 if (datumtype == 'A') {
4566                     while (len >= 10) {
4567                         sv_catpvn(cat, space10, 10);
4568                         len -= 10;
4569                     }
4570                     sv_catpvn(cat, space10, len);
4571                 }
4572                 else {
4573                     while (len >= 10) {
4574                         sv_catpvn(cat, null10, 10);
4575                         len -= 10;
4576                     }
4577                     sv_catpvn(cat, null10, len);
4578                 }
4579             }
4580             break;
4581         case 'B':
4582         case 'b':
4583             {
4584                 register char *str;
4585                 I32 saveitems;
4586
4587                 fromstr = NEXTFROM;
4588                 saveitems = items;
4589                 str = SvPV(fromstr, fromlen);
4590                 if (pat[-1] == '*')
4591                     len = fromlen;
4592                 aint = SvCUR(cat);
4593                 SvCUR(cat) += (len+7)/8;
4594                 SvGROW(cat, SvCUR(cat) + 1);
4595                 aptr = SvPVX(cat) + aint;
4596                 if (len > fromlen)
4597                     len = fromlen;
4598                 aint = len;
4599                 items = 0;
4600                 if (datumtype == 'B') {
4601                     for (len = 0; len++ < aint;) {
4602                         items |= *str++ & 1;
4603                         if (len & 7)
4604                             items <<= 1;
4605                         else {
4606                             *aptr++ = items & 0xff;
4607                             items = 0;
4608                         }
4609                     }
4610                 }
4611                 else {
4612                     for (len = 0; len++ < aint;) {
4613                         if (*str++ & 1)
4614                             items |= 128;
4615                         if (len & 7)
4616                             items >>= 1;
4617                         else {
4618                             *aptr++ = items & 0xff;
4619                             items = 0;
4620                         }
4621                     }
4622                 }
4623                 if (aint & 7) {
4624                     if (datumtype == 'B')
4625                         items <<= 7 - (aint & 7);
4626                     else
4627                         items >>= 7 - (aint & 7);
4628                     *aptr++ = items & 0xff;
4629                 }
4630                 str = SvPVX(cat) + SvCUR(cat);
4631                 while (aptr <= str)
4632                     *aptr++ = '\0';
4633
4634                 items = saveitems;
4635             }
4636             break;
4637         case 'H':
4638         case 'h':
4639             {
4640                 register char *str;
4641                 I32 saveitems;
4642
4643                 fromstr = NEXTFROM;
4644                 saveitems = items;
4645                 str = SvPV(fromstr, fromlen);
4646                 if (pat[-1] == '*')
4647                     len = fromlen;
4648                 aint = SvCUR(cat);
4649                 SvCUR(cat) += (len+1)/2;
4650                 SvGROW(cat, SvCUR(cat) + 1);
4651                 aptr = SvPVX(cat) + aint;
4652                 if (len > fromlen)
4653                     len = fromlen;
4654                 aint = len;
4655                 items = 0;
4656                 if (datumtype == 'H') {
4657                     for (len = 0; len++ < aint;) {
4658                         if (isALPHA(*str))
4659                             items |= ((*str++ & 15) + 9) & 15;
4660                         else
4661                             items |= *str++ & 15;
4662                         if (len & 1)
4663                             items <<= 4;
4664                         else {
4665                             *aptr++ = items & 0xff;
4666                             items = 0;
4667                         }
4668                     }
4669                 }
4670                 else {
4671                     for (len = 0; len++ < aint;) {
4672                         if (isALPHA(*str))
4673                             items |= (((*str++ & 15) + 9) & 15) << 4;
4674                         else
4675                             items |= (*str++ & 15) << 4;
4676                         if (len & 1)
4677                             items >>= 4;
4678                         else {
4679                             *aptr++ = items & 0xff;
4680                             items = 0;
4681                         }
4682                     }
4683                 }
4684                 if (aint & 1)
4685                     *aptr++ = items & 0xff;
4686                 str = SvPVX(cat) + SvCUR(cat);
4687                 while (aptr <= str)
4688                     *aptr++ = '\0';
4689
4690                 items = saveitems;
4691             }
4692             break;
4693         case 'C':
4694         case 'c':
4695             while (len-- > 0) {
4696                 fromstr = NEXTFROM;
4697                 aint = SvIV(fromstr);
4698                 achar = aint;
4699                 sv_catpvn(cat, &achar, sizeof(char));
4700             }
4701             break;
4702         case 'U':
4703             while (len-- > 0) {
4704                 fromstr = NEXTFROM;
4705                 auint = SvUV(fromstr);
4706                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4707                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4708                                - SvPVX(cat));
4709             }
4710             *SvEND(cat) = '\0';
4711             break;
4712         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4713         case 'f':
4714         case 'F':
4715             while (len-- > 0) {
4716                 fromstr = NEXTFROM;
4717                 afloat = (float)SvNV(fromstr);
4718                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4719             }
4720             break;
4721         case 'd':
4722         case 'D':
4723             while (len-- > 0) {
4724                 fromstr = NEXTFROM;
4725                 adouble = (double)SvNV(fromstr);
4726                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4727             }
4728             break;
4729         case 'n':
4730             while (len-- > 0) {
4731                 fromstr = NEXTFROM;
4732                 ashort = (I16)SvIV(fromstr);
4733 #ifdef HAS_HTONS
4734                 ashort = PerlSock_htons(ashort);
4735 #endif
4736                 CAT16(cat, &ashort);
4737             }
4738             break;
4739         case 'v':
4740             while (len-- > 0) {
4741                 fromstr = NEXTFROM;
4742                 ashort = (I16)SvIV(fromstr);
4743 #ifdef HAS_HTOVS
4744                 ashort = htovs(ashort);
4745 #endif
4746                 CAT16(cat, &ashort);
4747             }
4748             break;
4749         case 'S':
4750 #if SHORTSIZE != SIZE16
4751             if (natint) {
4752                 unsigned short aushort;
4753
4754                 while (len-- > 0) {
4755                     fromstr = NEXTFROM;
4756                     aushort = SvUV(fromstr);
4757                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4758                 }
4759             }
4760             else
4761 #endif
4762             {
4763                 U16 aushort;
4764
4765                 while (len-- > 0) {
4766                     fromstr = NEXTFROM;
4767                     aushort = (U16)SvUV(fromstr);
4768                     CAT16(cat, &aushort);
4769                 }
4770
4771             }
4772             break;
4773         case 's':
4774 #if SHORTSIZE != SIZE16
4775             if (natint) {
4776                 short ashort;
4777
4778                 while (len-- > 0) {
4779                     fromstr = NEXTFROM;
4780                     ashort = SvIV(fromstr);
4781                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4782                 }
4783             }
4784             else
4785 #endif
4786             {
4787                 while (len-- > 0) {
4788                     fromstr = NEXTFROM;
4789                     ashort = (I16)SvIV(fromstr);
4790                     CAT16(cat, &ashort);
4791                 }
4792             }
4793             break;
4794         case 'I':
4795             while (len-- > 0) {
4796                 fromstr = NEXTFROM;
4797                 auint = SvUV(fromstr);
4798                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4799             }
4800             break;
4801         case 'w':
4802             while (len-- > 0) {
4803                 fromstr = NEXTFROM;
4804                 adouble = Perl_floor(SvNV(fromstr));
4805
4806                 if (adouble < 0)
4807                     DIE(aTHX_ "Cannot compress negative numbers");
4808
4809                 if (
4810 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4811                     adouble <= 0xffffffff
4812 #else
4813 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
4814                     adouble <= UV_MAX_cxux
4815 #   else
4816                     adouble <= UV_MAX
4817 #   endif
4818 #endif
4819                     )
4820                 {
4821                     char   buf[1 + sizeof(UV)];
4822                     char  *in = buf + sizeof(buf);
4823                     UV     auv = U_V(adouble);
4824
4825                     do {
4826                         *--in = (auv & 0x7f) | 0x80;
4827                         auv >>= 7;
4828                     } while (auv);
4829                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4830                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4831                 }
4832                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4833                     char           *from, *result, *in;
4834                     SV             *norm;
4835                     STRLEN          len;
4836                     bool            done;
4837
4838                     /* Copy string and check for compliance */
4839                     from = SvPV(fromstr, len);
4840                     if ((norm = is_an_int(from, len)) == NULL)
4841                         DIE(aTHX_ "can compress only unsigned integer");
4842
4843                     New('w', result, len, char);
4844                     in = result + len;
4845                     done = FALSE;
4846                     while (!done)
4847                         *--in = div128(norm, &done) | 0x80;
4848                     result[len - 1] &= 0x7F; /* clear continue bit */
4849                     sv_catpvn(cat, in, (result + len) - in);
4850                     Safefree(result);
4851                     SvREFCNT_dec(norm); /* free norm */
4852                 }
4853                 else if (SvNOKp(fromstr)) {
4854                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4855                     char  *in = buf + sizeof(buf);
4856
4857                     do {
4858                         double next = floor(adouble / 128);
4859                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4860                         if (in <= buf)  /* this cannot happen ;-) */
4861                             DIE(aTHX_ "Cannot compress integer");
4862                         in--;
4863                         adouble = next;
4864                     } while (adouble > 0);
4865                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4866                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4867                 }
4868                 else
4869                     DIE(aTHX_ "Cannot compress non integer");
4870             }
4871             break;
4872         case 'i':
4873             while (len-- > 0) {
4874                 fromstr = NEXTFROM;
4875                 aint = SvIV(fromstr);
4876                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4877             }
4878             break;
4879         case 'N':
4880             while (len-- > 0) {
4881                 fromstr = NEXTFROM;
4882                 aulong = SvUV(fromstr);
4883 #ifdef HAS_HTONL
4884                 aulong = PerlSock_htonl(aulong);
4885 #endif
4886                 CAT32(cat, &aulong);
4887             }
4888             break;
4889         case 'V':
4890             while (len-- > 0) {
4891                 fromstr = NEXTFROM;
4892                 aulong = SvUV(fromstr);
4893 #ifdef HAS_HTOVL
4894                 aulong = htovl(aulong);
4895 #endif
4896                 CAT32(cat, &aulong);
4897             }
4898             break;
4899         case 'L':
4900 #if LONGSIZE != SIZE32
4901             if (natint) {
4902                 unsigned long aulong;
4903
4904                 while (len-- > 0) {
4905                     fromstr = NEXTFROM;
4906                     aulong = SvUV(fromstr);
4907                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4908                 }
4909             }
4910             else
4911 #endif
4912             {
4913                 while (len-- > 0) {
4914                     fromstr = NEXTFROM;
4915                     aulong = SvUV(fromstr);
4916                     CAT32(cat, &aulong);
4917                 }
4918             }
4919             break;
4920         case 'l':
4921 #if LONGSIZE != SIZE32
4922             if (natint) {
4923                 long along;
4924
4925                 while (len-- > 0) {
4926                     fromstr = NEXTFROM;
4927                     along = SvIV(fromstr);
4928                     sv_catpvn(cat, (char *)&along, sizeof(long));
4929                 }
4930             }
4931             else
4932 #endif
4933             {
4934                 while (len-- > 0) {
4935                     fromstr = NEXTFROM;
4936                     along = SvIV(fromstr);
4937                     CAT32(cat, &along);
4938                 }
4939             }
4940             break;
4941 #ifdef HAS_QUAD
4942         case 'Q':
4943             while (len-- > 0) {
4944                 fromstr = NEXTFROM;
4945                 auquad = (Uquad_t)SvUV(fromstr);
4946                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4947             }
4948             break;
4949         case 'q':
4950             while (len-- > 0) {
4951                 fromstr = NEXTFROM;
4952                 aquad = (Quad_t)SvIV(fromstr);
4953                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4954             }
4955             break;
4956 #endif
4957         case 'P':
4958             len = 1;            /* assume SV is correct length */
4959             /* FALL THROUGH */
4960         case 'p':
4961             while (len-- > 0) {
4962                 fromstr = NEXTFROM;
4963                 if (fromstr == &PL_sv_undef)
4964                     aptr = NULL;
4965                 else {
4966                     STRLEN n_a;
4967                     /* XXX better yet, could spirit away the string to
4968                      * a safe spot and hang on to it until the result
4969                      * of pack() (and all copies of the result) are
4970                      * gone.
4971                      */
4972                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4973                                                 || (SvPADTMP(fromstr)
4974                                                     && !SvREADONLY(fromstr))))
4975                     {
4976                         Perl_warner(aTHX_ WARN_PACK,
4977                                 "Attempt to pack pointer to temporary value");
4978                     }
4979                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4980                         aptr = SvPV(fromstr,n_a);
4981                     else
4982                         aptr = SvPV_force(fromstr,n_a);
4983                 }
4984                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4985             }
4986             break;
4987         case 'u':
4988             fromstr = NEXTFROM;
4989             aptr = SvPV(fromstr, fromlen);
4990             SvGROW(cat, fromlen * 4 / 3);
4991             if (len <= 1)
4992                 len = 45;
4993             else
4994                 len = len / 3 * 3;
4995             while (fromlen > 0) {
4996                 I32 todo;
4997
4998                 if (fromlen > len)
4999                     todo = len;
5000                 else
5001                     todo = fromlen;
5002                 doencodes(cat, aptr, todo);
5003                 fromlen -= todo;
5004                 aptr += todo;
5005             }
5006             break;
5007         }
5008     }
5009     SvSETMAGIC(cat);
5010     SP = ORIGMARK;
5011     PUSHs(cat);
5012     RETURN;
5013 }
5014 #undef NEXTFROM
5015
5016
5017 PP(pp_split)
5018 {
5019     djSP; dTARG;
5020     AV *ary;
5021     register IV limit = POPi;                   /* note, negative is forever */
5022     SV *sv = POPs;
5023     bool doutf8 = DO_UTF8(sv);
5024     STRLEN len;
5025     register char *s = SvPV(sv, len);
5026     char *strend = s + len;
5027     register PMOP *pm;
5028     register REGEXP *rx;
5029     register SV *dstr;
5030     register char *m;
5031     I32 iters = 0;
5032     I32 maxiters = (strend - s) + 10;
5033     I32 i;
5034     char *orig;
5035     I32 origlimit = limit;
5036     I32 realarray = 0;
5037     I32 base;
5038     AV *oldstack = PL_curstack;
5039     I32 gimme = GIMME_V;
5040     I32 oldsave = PL_savestack_ix;
5041     I32 make_mortal = 1;
5042     MAGIC *mg = (MAGIC *) NULL;
5043
5044 #ifdef DEBUGGING
5045     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5046 #else
5047     pm = (PMOP*)POPs;
5048 #endif
5049     if (!pm || !s)
5050         DIE(aTHX_ "panic: do_split");
5051     rx = pm->op_pmregexp;
5052
5053     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5054              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5055
5056     if (pm->op_pmreplroot) {
5057 #ifdef USE_ITHREADS
5058         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5059 #else
5060         ary = GvAVn((GV*)pm->op_pmreplroot);
5061 #endif
5062     }
5063     else if (gimme != G_ARRAY)
5064 #ifdef USE_THREADS
5065         ary = (AV*)PL_curpad[0];
5066 #else
5067         ary = GvAVn(PL_defgv);
5068 #endif /* USE_THREADS */
5069     else
5070         ary = Nullav;
5071     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5072         realarray = 1;
5073         PUTBACK;
5074         av_extend(ary,0);
5075         av_clear(ary);
5076         SPAGAIN;
5077         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5078             PUSHMARK(SP);
5079             XPUSHs(SvTIED_obj((SV*)ary, mg));
5080         }
5081         else {
5082             if (!AvREAL(ary)) {
5083                 AvREAL_on(ary);
5084                 AvREIFY_off(ary);
5085                 for (i = AvFILLp(ary); i >= 0; i--)
5086                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5087             }
5088             /* temporarily switch stacks */
5089             SWITCHSTACK(PL_curstack, ary);
5090             make_mortal = 0;
5091         }
5092     }
5093     base = SP - PL_stack_base;
5094     orig = s;
5095     if (pm->op_pmflags & PMf_SKIPWHITE) {
5096         if (pm->op_pmflags & PMf_LOCALE) {
5097             while (isSPACE_LC(*s))
5098                 s++;
5099         }
5100         else {
5101             while (isSPACE(*s))
5102                 s++;
5103         }
5104     }
5105     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5106         SAVEINT(PL_multiline);
5107         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5108     }
5109
5110     if (!limit)
5111         limit = maxiters + 2;
5112     if (pm->op_pmflags & PMf_WHITE) {
5113         while (--limit) {
5114             m = s;
5115             while (m < strend &&
5116                    !((pm->op_pmflags & PMf_LOCALE)
5117                      ? isSPACE_LC(*m) : isSPACE(*m)))
5118                 ++m;
5119             if (m >= strend)
5120                 break;
5121
5122             dstr = NEWSV(30, m-s);
5123             sv_setpvn(dstr, s, m-s);
5124             if (make_mortal)
5125                 sv_2mortal(dstr);
5126             if (doutf8)
5127                 (void)SvUTF8_on(dstr);
5128             XPUSHs(dstr);
5129
5130             s = m + 1;
5131             while (s < strend &&
5132                    ((pm->op_pmflags & PMf_LOCALE)
5133                     ? isSPACE_LC(*s) : isSPACE(*s)))
5134                 ++s;
5135         }
5136     }
5137     else if (strEQ("^", rx->precomp)) {
5138         while (--limit) {
5139             /*SUPPRESS 530*/
5140             for (m = s; m < strend && *m != '\n'; m++) ;
5141             m++;
5142             if (m >= strend)
5143                 break;
5144             dstr = NEWSV(30, m-s);
5145             sv_setpvn(dstr, s, m-s);
5146             if (make_mortal)
5147                 sv_2mortal(dstr);
5148             if (doutf8)
5149                 (void)SvUTF8_on(dstr);
5150             XPUSHs(dstr);
5151             s = m;
5152         }
5153     }
5154     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5155              && (rx->reganch & ROPT_CHECK_ALL)
5156              && !(rx->reganch & ROPT_ANCH)) {
5157         int tail = (rx->reganch & RE_INTUIT_TAIL);
5158         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5159
5160         len = rx->minlen;
5161         if (len == 1 && !tail) {
5162             STRLEN n_a;
5163             char c = *SvPV(csv, n_a);
5164             while (--limit) {
5165                 /*SUPPRESS 530*/
5166                 for (m = s; m < strend && *m != c; m++) ;
5167                 if (m >= strend)
5168                     break;
5169                 dstr = NEWSV(30, m-s);
5170                 sv_setpvn(dstr, s, m-s);
5171                 if (make_mortal)
5172                     sv_2mortal(dstr);
5173                 if (doutf8)
5174                     (void)SvUTF8_on(dstr);
5175                 XPUSHs(dstr);
5176                 /* The rx->minlen is in characters but we want to step
5177                  * s ahead by bytes. */
5178                 s = m + (doutf8 ? SvCUR(csv) : len);
5179             }
5180         }
5181         else {
5182 #ifndef lint
5183             while (s < strend && --limit &&
5184               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5185                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5186 #endif
5187             {
5188                 dstr = NEWSV(31, m-s);
5189                 sv_setpvn(dstr, s, m-s);
5190                 if (make_mortal)
5191                     sv_2mortal(dstr);
5192                 if (doutf8)
5193                     (void)SvUTF8_on(dstr);
5194                 XPUSHs(dstr);
5195                 /* The rx->minlen is in characters but we want to step
5196                  * s ahead by bytes. */
5197                 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5198             }
5199         }
5200     }
5201     else {
5202         maxiters += (strend - s) * rx->nparens;
5203         while (s < strend && --limit
5204 /*             && (!rx->check_substr
5205                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5206                                                  0, NULL))))
5207 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5208                               1 /* minend */, sv, NULL, 0))
5209         {
5210             TAINT_IF(RX_MATCH_TAINTED(rx));
5211             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5212                 m = s;
5213                 s = orig;
5214                 orig = rx->subbeg;
5215                 s = orig + (m - s);
5216                 strend = s + (strend - m);
5217             }
5218             m = rx->startp[0] + orig;
5219             dstr = NEWSV(32, m-s);
5220             sv_setpvn(dstr, s, m-s);
5221             if (make_mortal)
5222                 sv_2mortal(dstr);
5223             if (doutf8)
5224                 (void)SvUTF8_on(dstr);
5225             XPUSHs(dstr);
5226             if (rx->nparens) {
5227                 for (i = 1; i <= rx->nparens; i++) {
5228                     s = rx->startp[i] + orig;
5229                     m = rx->endp[i] + orig;
5230                     if (m && s) {
5231                         dstr = NEWSV(33, m-s);
5232                         sv_setpvn(dstr, s, m-s);
5233                     }
5234                     else
5235                         dstr = NEWSV(33, 0);
5236                     if (make_mortal)
5237                         sv_2mortal(dstr);
5238                     if (doutf8)
5239                         (void)SvUTF8_on(dstr);
5240                     XPUSHs(dstr);
5241                 }
5242             }
5243             s = rx->endp[0] + orig;
5244         }
5245     }
5246
5247     LEAVE_SCOPE(oldsave);
5248     iters = (SP - PL_stack_base) - base;
5249     if (iters > maxiters)
5250         DIE(aTHX_ "Split loop");
5251
5252     /* keep field after final delim? */
5253     if (s < strend || (iters && origlimit)) {
5254         STRLEN l = strend - s;
5255         dstr = NEWSV(34, l);
5256         sv_setpvn(dstr, s, l);
5257         if (make_mortal)
5258             sv_2mortal(dstr);
5259         if (doutf8)
5260             (void)SvUTF8_on(dstr);
5261         XPUSHs(dstr);
5262         iters++;
5263     }
5264     else if (!origlimit) {
5265         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5266             iters--, SP--;
5267     }
5268
5269     if (realarray) {
5270         if (!mg) {
5271             SWITCHSTACK(ary, oldstack);
5272             if (SvSMAGICAL(ary)) {
5273                 PUTBACK;
5274                 mg_set((SV*)ary);
5275                 SPAGAIN;
5276             }
5277             if (gimme == G_ARRAY) {
5278                 EXTEND(SP, iters);
5279                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5280                 SP += iters;
5281                 RETURN;
5282             }
5283         }
5284         else {
5285             PUTBACK;
5286             ENTER;
5287             call_method("PUSH",G_SCALAR|G_DISCARD);
5288             LEAVE;
5289             SPAGAIN;
5290             if (gimme == G_ARRAY) {
5291                 /* EXTEND should not be needed - we just popped them */
5292                 EXTEND(SP, iters);
5293                 for (i=0; i < iters; i++) {
5294                     SV **svp = av_fetch(ary, i, FALSE);
5295                     PUSHs((svp) ? *svp : &PL_sv_undef);
5296                 }
5297                 RETURN;
5298             }
5299         }
5300     }
5301     else {
5302         if (gimme == G_ARRAY)
5303             RETURN;
5304     }
5305     if (iters || !pm->op_pmreplroot) {
5306         GETTARGET;
5307         PUSHi(iters);
5308         RETURN;
5309     }
5310     RETPUSHUNDEF;
5311 }
5312
5313 #ifdef USE_THREADS
5314 void
5315 Perl_unlock_condpair(pTHX_ void *svv)
5316 {
5317     dTHR;
5318     MAGIC *mg = mg_find((SV*)svv, 'm');
5319
5320     if (!mg)
5321         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5322     MUTEX_LOCK(MgMUTEXP(mg));
5323     if (MgOWNER(mg) != thr)
5324         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5325     MgOWNER(mg) = 0;
5326     COND_SIGNAL(MgOWNERCONDP(mg));
5327     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5328                           PTR2UV(thr), PTR2UV(svv));)
5329     MUTEX_UNLOCK(MgMUTEXP(mg));
5330 }
5331 #endif /* USE_THREADS */
5332
5333 PP(pp_lock)
5334 {
5335     djSP;
5336     dTOPss;
5337     SV *retsv = sv;
5338 #ifdef USE_THREADS
5339     sv_lock(sv);
5340 #endif /* USE_THREADS */
5341     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5342         || SvTYPE(retsv) == SVt_PVCV) {
5343         retsv = refto(retsv);
5344     }
5345     SETs(retsv);
5346     RETURN;
5347 }
5348
5349 PP(pp_threadsv)
5350 {
5351 #ifdef USE_THREADS
5352     djSP;
5353     EXTEND(SP, 1);
5354     if (PL_op->op_private & OPpLVAL_INTRO)
5355         PUSHs(*save_threadsv(PL_op->op_targ));
5356     else
5357         PUSHs(THREADSV(PL_op->op_targ));
5358     RETURN;
5359 #else
5360     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5361 #endif /* USE_THREADS */
5362 }