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