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