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     char *patcopy;
4379     register char *patend = pat + fromlen;
4380     register I32 len;
4381     I32 datumtype;
4382     SV *fromstr;
4383     /*SUPPRESS 442*/
4384     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4385     static char *space10 = "          ";
4386
4387     /* These must not be in registers: */
4388     char achar;
4389     I16 ashort;
4390     int aint;
4391     unsigned int auint;
4392     I32 along;
4393     U32 aulong;
4394 #ifdef HAS_QUAD
4395     Quad_t aquad;
4396     Uquad_t auquad;
4397 #endif
4398     char *aptr;
4399     float afloat;
4400     double adouble;
4401     int commas = 0;
4402 #ifdef PERL_NATINT_PACK
4403     int natint;         /* native integer */
4404 #endif
4405
4406     items = SP - MARK;
4407     MARK++;
4408     sv_setpvn(cat, "", 0);
4409     patcopy = pat;
4410     while (pat < patend) {
4411         SV *lengthcode = Nullsv;
4412 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4413         datumtype = *pat++ & 0xFF;
4414 #ifdef PERL_NATINT_PACK
4415         natint = 0;
4416 #endif
4417         if (isSPACE(datumtype)) {
4418             patcopy++;
4419             continue;
4420         }
4421         if (datumtype == 'U' && pat == patcopy+1)
4422             SvUTF8_on(cat);
4423         if (datumtype == '#') {
4424             while (pat < patend && *pat != '\n')
4425                 pat++;
4426             continue;
4427         }
4428         if (*pat == '!') {
4429             char *natstr = "sSiIlL";
4430
4431             if (strchr(natstr, datumtype)) {
4432 #ifdef PERL_NATINT_PACK
4433                 natint = 1;
4434 #endif
4435                 pat++;
4436             }
4437             else
4438                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4439         }
4440         if (*pat == '*') {
4441             len = strchr("@Xxu", datumtype) ? 0 : items;
4442             pat++;
4443         }
4444         else if (isDIGIT(*pat)) {
4445             len = *pat++ - '0';
4446             while (isDIGIT(*pat)) {
4447                 len = (len * 10) + (*pat++ - '0');
4448                 if (len < 0)
4449                     DIE(aTHX_ "Repeat count in pack overflows");
4450             }
4451         }
4452         else
4453             len = 1;
4454         if (*pat == '/') {
4455             ++pat;
4456             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4457                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4458             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4459                                                    ? *MARK : &PL_sv_no)
4460                                             + (*pat == 'Z' ? 1 : 0)));
4461         }
4462         switch(datumtype) {
4463         default:
4464             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4465         case ',': /* grandfather in commas but with a warning */
4466             if (commas++ == 0 && ckWARN(WARN_PACK))
4467                 Perl_warner(aTHX_ WARN_PACK,
4468                             "Invalid type in pack: '%c'", (int)datumtype);
4469             break;
4470         case '%':
4471             DIE(aTHX_ "%% may only be used in unpack");
4472         case '@':
4473             len -= SvCUR(cat);
4474             if (len > 0)
4475                 goto grow;
4476             len = -len;
4477             if (len > 0)
4478                 goto shrink;
4479             break;
4480         case 'X':
4481           shrink:
4482             if (SvCUR(cat) < len)
4483                 DIE(aTHX_ "X outside of string");
4484             SvCUR(cat) -= len;
4485             *SvEND(cat) = '\0';
4486             break;
4487         case 'x':
4488           grow:
4489             while (len >= 10) {
4490                 sv_catpvn(cat, null10, 10);
4491                 len -= 10;
4492             }
4493             sv_catpvn(cat, null10, len);
4494             break;
4495         case 'A':
4496         case 'Z':
4497         case 'a':
4498             fromstr = NEXTFROM;
4499             aptr = SvPV(fromstr, fromlen);
4500             if (pat[-1] == '*') {
4501                 len = fromlen;
4502                 if (datumtype == 'Z')
4503                     ++len;
4504             }
4505             if (fromlen >= len) {
4506                 sv_catpvn(cat, aptr, len);
4507                 if (datumtype == 'Z')
4508                     *(SvEND(cat)-1) = '\0';
4509             }
4510             else {
4511                 sv_catpvn(cat, aptr, fromlen);
4512                 len -= fromlen;
4513                 if (datumtype == 'A') {
4514                     while (len >= 10) {
4515                         sv_catpvn(cat, space10, 10);
4516                         len -= 10;
4517                     }
4518                     sv_catpvn(cat, space10, len);
4519                 }
4520                 else {
4521                     while (len >= 10) {
4522                         sv_catpvn(cat, null10, 10);
4523                         len -= 10;
4524                     }
4525                     sv_catpvn(cat, null10, len);
4526                 }
4527             }
4528             break;
4529         case 'B':
4530         case 'b':
4531             {
4532                 register char *str;
4533                 I32 saveitems;
4534
4535                 fromstr = NEXTFROM;
4536                 saveitems = items;
4537                 str = SvPV(fromstr, fromlen);
4538                 if (pat[-1] == '*')
4539                     len = fromlen;
4540                 aint = SvCUR(cat);
4541                 SvCUR(cat) += (len+7)/8;
4542                 SvGROW(cat, SvCUR(cat) + 1);
4543                 aptr = SvPVX(cat) + aint;
4544                 if (len > fromlen)
4545                     len = fromlen;
4546                 aint = len;
4547                 items = 0;
4548                 if (datumtype == 'B') {
4549                     for (len = 0; len++ < aint;) {
4550                         items |= *str++ & 1;
4551                         if (len & 7)
4552                             items <<= 1;
4553                         else {
4554                             *aptr++ = items & 0xff;
4555                             items = 0;
4556                         }
4557                     }
4558                 }
4559                 else {
4560                     for (len = 0; len++ < aint;) {
4561                         if (*str++ & 1)
4562                             items |= 128;
4563                         if (len & 7)
4564                             items >>= 1;
4565                         else {
4566                             *aptr++ = items & 0xff;
4567                             items = 0;
4568                         }
4569                     }
4570                 }
4571                 if (aint & 7) {
4572                     if (datumtype == 'B')
4573                         items <<= 7 - (aint & 7);
4574                     else
4575                         items >>= 7 - (aint & 7);
4576                     *aptr++ = items & 0xff;
4577                 }
4578                 str = SvPVX(cat) + SvCUR(cat);
4579                 while (aptr <= str)
4580                     *aptr++ = '\0';
4581
4582                 items = saveitems;
4583             }
4584             break;
4585         case 'H':
4586         case 'h':
4587             {
4588                 register char *str;
4589                 I32 saveitems;
4590
4591                 fromstr = NEXTFROM;
4592                 saveitems = items;
4593                 str = SvPV(fromstr, fromlen);
4594                 if (pat[-1] == '*')
4595                     len = fromlen;
4596                 aint = SvCUR(cat);
4597                 SvCUR(cat) += (len+1)/2;
4598                 SvGROW(cat, SvCUR(cat) + 1);
4599                 aptr = SvPVX(cat) + aint;
4600                 if (len > fromlen)
4601                     len = fromlen;
4602                 aint = len;
4603                 items = 0;
4604                 if (datumtype == 'H') {
4605                     for (len = 0; len++ < aint;) {
4606                         if (isALPHA(*str))
4607                             items |= ((*str++ & 15) + 9) & 15;
4608                         else
4609                             items |= *str++ & 15;
4610                         if (len & 1)
4611                             items <<= 4;
4612                         else {
4613                             *aptr++ = items & 0xff;
4614                             items = 0;
4615                         }
4616                     }
4617                 }
4618                 else {
4619                     for (len = 0; len++ < aint;) {
4620                         if (isALPHA(*str))
4621                             items |= (((*str++ & 15) + 9) & 15) << 4;
4622                         else
4623                             items |= (*str++ & 15) << 4;
4624                         if (len & 1)
4625                             items >>= 4;
4626                         else {
4627                             *aptr++ = items & 0xff;
4628                             items = 0;
4629                         }
4630                     }
4631                 }
4632                 if (aint & 1)
4633                     *aptr++ = items & 0xff;
4634                 str = SvPVX(cat) + SvCUR(cat);
4635                 while (aptr <= str)
4636                     *aptr++ = '\0';
4637
4638                 items = saveitems;
4639             }
4640             break;
4641         case 'C':
4642         case 'c':
4643             while (len-- > 0) {
4644                 fromstr = NEXTFROM;
4645                 aint = SvIV(fromstr);
4646                 achar = aint;
4647                 sv_catpvn(cat, &achar, sizeof(char));
4648             }
4649             break;
4650         case 'U':
4651             while (len-- > 0) {
4652                 fromstr = NEXTFROM;
4653                 auint = SvUV(fromstr);
4654                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4655                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4656                                - SvPVX(cat));
4657             }
4658             *SvEND(cat) = '\0';
4659             break;
4660         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4661         case 'f':
4662         case 'F':
4663             while (len-- > 0) {
4664                 fromstr = NEXTFROM;
4665                 afloat = (float)SvNV(fromstr);
4666                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4667             }
4668             break;
4669         case 'd':
4670         case 'D':
4671             while (len-- > 0) {
4672                 fromstr = NEXTFROM;
4673                 adouble = (double)SvNV(fromstr);
4674                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4675             }
4676             break;
4677         case 'n':
4678             while (len-- > 0) {
4679                 fromstr = NEXTFROM;
4680                 ashort = (I16)SvIV(fromstr);
4681 #ifdef HAS_HTONS
4682                 ashort = PerlSock_htons(ashort);
4683 #endif
4684                 CAT16(cat, &ashort);
4685             }
4686             break;
4687         case 'v':
4688             while (len-- > 0) {
4689                 fromstr = NEXTFROM;
4690                 ashort = (I16)SvIV(fromstr);
4691 #ifdef HAS_HTOVS
4692                 ashort = htovs(ashort);
4693 #endif
4694                 CAT16(cat, &ashort);
4695             }
4696             break;
4697         case 'S':
4698 #if SHORTSIZE != SIZE16
4699             if (natint) {
4700                 unsigned short aushort;
4701
4702                 while (len-- > 0) {
4703                     fromstr = NEXTFROM;
4704                     aushort = SvUV(fromstr);
4705                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4706                 }
4707             }
4708             else
4709 #endif
4710             {
4711                 U16 aushort;
4712
4713                 while (len-- > 0) {
4714                     fromstr = NEXTFROM;
4715                     aushort = (U16)SvUV(fromstr);
4716                     CAT16(cat, &aushort);
4717                 }
4718
4719             }
4720             break;
4721         case 's':
4722 #if SHORTSIZE != SIZE16
4723             if (natint) {
4724                 short ashort;
4725
4726                 while (len-- > 0) {
4727                     fromstr = NEXTFROM;
4728                     ashort = SvIV(fromstr);
4729                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4730                 }
4731             }
4732             else
4733 #endif
4734             {
4735                 while (len-- > 0) {
4736                     fromstr = NEXTFROM;
4737                     ashort = (I16)SvIV(fromstr);
4738                     CAT16(cat, &ashort);
4739                 }
4740             }
4741             break;
4742         case 'I':
4743             while (len-- > 0) {
4744                 fromstr = NEXTFROM;
4745                 auint = SvUV(fromstr);
4746                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4747             }
4748             break;
4749         case 'w':
4750             while (len-- > 0) {
4751                 fromstr = NEXTFROM;
4752                 adouble = Perl_floor(SvNV(fromstr));
4753
4754                 if (adouble < 0)
4755                     DIE(aTHX_ "Cannot compress negative numbers");
4756
4757                 if (
4758 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4759                     adouble <= 0xffffffff
4760 #else
4761 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
4762                     adouble <= UV_MAX_cxux
4763 #   else
4764                     adouble <= UV_MAX
4765 #   endif
4766 #endif
4767                     )
4768                 {
4769                     char   buf[1 + sizeof(UV)];
4770                     char  *in = buf + sizeof(buf);
4771                     UV     auv = U_V(adouble);
4772
4773                     do {
4774                         *--in = (auv & 0x7f) | 0x80;
4775                         auv >>= 7;
4776                     } while (auv);
4777                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4778                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4779                 }
4780                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4781                     char           *from, *result, *in;
4782                     SV             *norm;
4783                     STRLEN          len;
4784                     bool            done;
4785
4786                     /* Copy string and check for compliance */
4787                     from = SvPV(fromstr, len);
4788                     if ((norm = is_an_int(from, len)) == NULL)
4789                         DIE(aTHX_ "can compress only unsigned integer");
4790
4791                     New('w', result, len, char);
4792                     in = result + len;
4793                     done = FALSE;
4794                     while (!done)
4795                         *--in = div128(norm, &done) | 0x80;
4796                     result[len - 1] &= 0x7F; /* clear continue bit */
4797                     sv_catpvn(cat, in, (result + len) - in);
4798                     Safefree(result);
4799                     SvREFCNT_dec(norm); /* free norm */
4800                 }
4801                 else if (SvNOKp(fromstr)) {
4802                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4803                     char  *in = buf + sizeof(buf);
4804
4805                     do {
4806                         double next = floor(adouble / 128);
4807                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4808                         if (--in < buf)  /* this cannot happen ;-) */
4809                             DIE(aTHX_ "Cannot compress integer");
4810                         adouble = next;
4811                     } while (adouble > 0);
4812                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4813                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4814                 }
4815                 else
4816                     DIE(aTHX_ "Cannot compress non integer");
4817             }
4818             break;
4819         case 'i':
4820             while (len-- > 0) {
4821                 fromstr = NEXTFROM;
4822                 aint = SvIV(fromstr);
4823                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4824             }
4825             break;
4826         case 'N':
4827             while (len-- > 0) {
4828                 fromstr = NEXTFROM;
4829                 aulong = SvUV(fromstr);
4830 #ifdef HAS_HTONL
4831                 aulong = PerlSock_htonl(aulong);
4832 #endif
4833                 CAT32(cat, &aulong);
4834             }
4835             break;
4836         case 'V':
4837             while (len-- > 0) {
4838                 fromstr = NEXTFROM;
4839                 aulong = SvUV(fromstr);
4840 #ifdef HAS_HTOVL
4841                 aulong = htovl(aulong);
4842 #endif
4843                 CAT32(cat, &aulong);
4844             }
4845             break;
4846         case 'L':
4847 #if LONGSIZE != SIZE32
4848             if (natint) {
4849                 unsigned long aulong;
4850
4851                 while (len-- > 0) {
4852                     fromstr = NEXTFROM;
4853                     aulong = SvUV(fromstr);
4854                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4855                 }
4856             }
4857             else
4858 #endif
4859             {
4860                 while (len-- > 0) {
4861                     fromstr = NEXTFROM;
4862                     aulong = SvUV(fromstr);
4863                     CAT32(cat, &aulong);
4864                 }
4865             }
4866             break;
4867         case 'l':
4868 #if LONGSIZE != SIZE32
4869             if (natint) {
4870                 long along;
4871
4872                 while (len-- > 0) {
4873                     fromstr = NEXTFROM;
4874                     along = SvIV(fromstr);
4875                     sv_catpvn(cat, (char *)&along, sizeof(long));
4876                 }
4877             }
4878             else
4879 #endif
4880             {
4881                 while (len-- > 0) {
4882                     fromstr = NEXTFROM;
4883                     along = SvIV(fromstr);
4884                     CAT32(cat, &along);
4885                 }
4886             }
4887             break;
4888 #ifdef HAS_QUAD
4889         case 'Q':
4890             while (len-- > 0) {
4891                 fromstr = NEXTFROM;
4892                 auquad = (Uquad_t)SvUV(fromstr);
4893                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4894             }
4895             break;
4896         case 'q':
4897             while (len-- > 0) {
4898                 fromstr = NEXTFROM;
4899                 aquad = (Quad_t)SvIV(fromstr);
4900                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4901             }
4902             break;
4903 #endif
4904         case 'P':
4905             len = 1;            /* assume SV is correct length */
4906             /* FALL THROUGH */
4907         case 'p':
4908             while (len-- > 0) {
4909                 fromstr = NEXTFROM;
4910                 if (fromstr == &PL_sv_undef)
4911                     aptr = NULL;
4912                 else {
4913                     STRLEN n_a;
4914                     /* XXX better yet, could spirit away the string to
4915                      * a safe spot and hang on to it until the result
4916                      * of pack() (and all copies of the result) are
4917                      * gone.
4918                      */
4919                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4920                                                 || (SvPADTMP(fromstr)
4921                                                     && !SvREADONLY(fromstr))))
4922                     {
4923                         Perl_warner(aTHX_ WARN_PACK,
4924                                 "Attempt to pack pointer to temporary value");
4925                     }
4926                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4927                         aptr = SvPV(fromstr,n_a);
4928                     else
4929                         aptr = SvPV_force(fromstr,n_a);
4930                 }
4931                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4932             }
4933             break;
4934         case 'u':
4935             fromstr = NEXTFROM;
4936             aptr = SvPV(fromstr, fromlen);
4937             SvGROW(cat, fromlen * 4 / 3);
4938             if (len <= 1)
4939                 len = 45;
4940             else
4941                 len = len / 3 * 3;
4942             while (fromlen > 0) {
4943                 I32 todo;
4944
4945                 if (fromlen > len)
4946                     todo = len;
4947                 else
4948                     todo = fromlen;
4949                 doencodes(cat, aptr, todo);
4950                 fromlen -= todo;
4951                 aptr += todo;
4952             }
4953             break;
4954         }
4955     }
4956     SvSETMAGIC(cat);
4957     SP = ORIGMARK;
4958     PUSHs(cat);
4959     RETURN;
4960 }
4961 #undef NEXTFROM
4962
4963
4964 PP(pp_split)
4965 {
4966     djSP; dTARG;
4967     AV *ary;
4968     register I32 limit = POPi;                  /* note, negative is forever */
4969     SV *sv = POPs;
4970     STRLEN len;
4971     register char *s = SvPV(sv, len);
4972     char *strend = s + len;
4973     register PMOP *pm;
4974     register REGEXP *rx;
4975     register SV *dstr;
4976     register char *m;
4977     I32 iters = 0;
4978     I32 maxiters = (strend - s) + 10;
4979     I32 i;
4980     char *orig;
4981     I32 origlimit = limit;
4982     I32 realarray = 0;
4983     I32 base;
4984     AV *oldstack = PL_curstack;
4985     I32 gimme = GIMME_V;
4986     I32 oldsave = PL_savestack_ix;
4987     I32 make_mortal = 1;
4988     MAGIC *mg = (MAGIC *) NULL;
4989
4990 #ifdef DEBUGGING
4991     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4992 #else
4993     pm = (PMOP*)POPs;
4994 #endif
4995     if (!pm || !s)
4996         DIE(aTHX_ "panic: do_split");
4997     rx = pm->op_pmregexp;
4998
4999     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5000              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5001
5002     if (pm->op_pmreplroot) {
5003 #ifdef USE_ITHREADS
5004         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5005 #else
5006         ary = GvAVn((GV*)pm->op_pmreplroot);
5007 #endif
5008     }
5009     else if (gimme != G_ARRAY)
5010 #ifdef USE_THREADS
5011         ary = (AV*)PL_curpad[0];
5012 #else
5013         ary = GvAVn(PL_defgv);
5014 #endif /* USE_THREADS */
5015     else
5016         ary = Nullav;
5017     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5018         realarray = 1;
5019         PUTBACK;
5020         av_extend(ary,0);
5021         av_clear(ary);
5022         SPAGAIN;
5023         if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5024             PUSHMARK(SP);
5025             XPUSHs(SvTIED_obj((SV*)ary, mg));
5026         }
5027         else {
5028             if (!AvREAL(ary)) {
5029                 AvREAL_on(ary);
5030                 AvREIFY_off(ary);
5031                 for (i = AvFILLp(ary); i >= 0; i--)
5032                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5033             }
5034             /* temporarily switch stacks */
5035             SWITCHSTACK(PL_curstack, ary);
5036             make_mortal = 0;
5037         }
5038     }
5039     base = SP - PL_stack_base;
5040     orig = s;
5041     if (pm->op_pmflags & PMf_SKIPWHITE) {
5042         if (pm->op_pmflags & PMf_LOCALE) {
5043             while (isSPACE_LC(*s))
5044                 s++;
5045         }
5046         else {
5047             while (isSPACE(*s))
5048                 s++;
5049         }
5050     }
5051     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5052         SAVEINT(PL_multiline);
5053         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5054     }
5055
5056     if (!limit)
5057         limit = maxiters + 2;
5058     if (pm->op_pmflags & PMf_WHITE) {
5059         while (--limit) {
5060             m = s;
5061             while (m < strend &&
5062                    !((pm->op_pmflags & PMf_LOCALE)
5063                      ? isSPACE_LC(*m) : isSPACE(*m)))
5064                 ++m;
5065             if (m >= strend)
5066                 break;
5067
5068             dstr = NEWSV(30, m-s);
5069             sv_setpvn(dstr, s, m-s);
5070             if (make_mortal)
5071                 sv_2mortal(dstr);
5072             XPUSHs(dstr);
5073
5074             s = m + 1;
5075             while (s < strend &&
5076                    ((pm->op_pmflags & PMf_LOCALE)
5077                     ? isSPACE_LC(*s) : isSPACE(*s)))
5078                 ++s;
5079         }
5080     }
5081     else if (strEQ("^", rx->precomp)) {
5082         while (--limit) {
5083             /*SUPPRESS 530*/
5084             for (m = s; m < strend && *m != '\n'; m++) ;
5085             m++;
5086             if (m >= strend)
5087                 break;
5088             dstr = NEWSV(30, m-s);
5089             sv_setpvn(dstr, s, m-s);
5090             if (make_mortal)
5091                 sv_2mortal(dstr);
5092             XPUSHs(dstr);
5093             s = m;
5094         }
5095     }
5096     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5097              && (rx->reganch & ROPT_CHECK_ALL)
5098              && !(rx->reganch & ROPT_ANCH)) {
5099         int tail = (rx->reganch & RE_INTUIT_TAIL);
5100         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5101         char c;
5102
5103         len = rx->minlen;
5104         if (len == 1 && !tail) {
5105             c = *SvPV(csv,len);
5106             while (--limit) {
5107                 /*SUPPRESS 530*/
5108                 for (m = s; m < strend && *m != c; m++) ;
5109                 if (m >= strend)
5110                     break;
5111                 dstr = NEWSV(30, m-s);
5112                 sv_setpvn(dstr, s, m-s);
5113                 if (make_mortal)
5114                     sv_2mortal(dstr);
5115                 XPUSHs(dstr);
5116                 s = m + 1;
5117             }
5118         }
5119         else {
5120 #ifndef lint
5121             while (s < strend && --limit &&
5122               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5123                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5124 #endif
5125             {
5126                 dstr = NEWSV(31, m-s);
5127                 sv_setpvn(dstr, s, m-s);
5128                 if (make_mortal)
5129                     sv_2mortal(dstr);
5130                 XPUSHs(dstr);
5131                 s = m + len;            /* Fake \n at the end */
5132             }
5133         }
5134     }
5135     else {
5136         maxiters += (strend - s) * rx->nparens;
5137         while (s < strend && --limit
5138 /*             && (!rx->check_substr
5139                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5140                                                  0, NULL))))
5141 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5142                               1 /* minend */, sv, NULL, 0))
5143         {
5144             TAINT_IF(RX_MATCH_TAINTED(rx));
5145             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5146                 m = s;
5147                 s = orig;
5148                 orig = rx->subbeg;
5149                 s = orig + (m - s);
5150                 strend = s + (strend - m);
5151             }
5152             m = rx->startp[0] + orig;
5153             dstr = NEWSV(32, m-s);
5154             sv_setpvn(dstr, s, m-s);
5155             if (make_mortal)
5156                 sv_2mortal(dstr);
5157             XPUSHs(dstr);
5158             if (rx->nparens) {
5159                 for (i = 1; i <= rx->nparens; i++) {
5160                     s = rx->startp[i] + orig;
5161                     m = rx->endp[i] + orig;
5162                     if (m && s) {
5163                         dstr = NEWSV(33, m-s);
5164                         sv_setpvn(dstr, s, m-s);
5165                     }
5166                     else
5167                         dstr = NEWSV(33, 0);
5168                     if (make_mortal)
5169                         sv_2mortal(dstr);
5170                     XPUSHs(dstr);
5171                 }
5172             }
5173             s = rx->endp[0] + orig;
5174         }
5175     }
5176
5177     LEAVE_SCOPE(oldsave);
5178     iters = (SP - PL_stack_base) - base;
5179     if (iters > maxiters)
5180         DIE(aTHX_ "Split loop");
5181
5182     /* keep field after final delim? */
5183     if (s < strend || (iters && origlimit)) {
5184         dstr = NEWSV(34, strend-s);
5185         sv_setpvn(dstr, s, strend-s);
5186         if (make_mortal)
5187             sv_2mortal(dstr);
5188         XPUSHs(dstr);
5189         iters++;
5190     }
5191     else if (!origlimit) {
5192         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5193             iters--, SP--;
5194     }
5195
5196     if (realarray) {
5197         if (!mg) {
5198             SWITCHSTACK(ary, oldstack);
5199             if (SvSMAGICAL(ary)) {
5200                 PUTBACK;
5201                 mg_set((SV*)ary);
5202                 SPAGAIN;
5203             }
5204             if (gimme == G_ARRAY) {
5205                 EXTEND(SP, iters);
5206                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5207                 SP += iters;
5208                 RETURN;
5209             }
5210         }
5211         else {
5212             PUTBACK;
5213             ENTER;
5214             call_method("PUSH",G_SCALAR|G_DISCARD);
5215             LEAVE;
5216             SPAGAIN;
5217             if (gimme == G_ARRAY) {
5218                 /* EXTEND should not be needed - we just popped them */
5219                 EXTEND(SP, iters);
5220                 for (i=0; i < iters; i++) {
5221                     SV **svp = av_fetch(ary, i, FALSE);
5222                     PUSHs((svp) ? *svp : &PL_sv_undef);
5223                 }
5224                 RETURN;
5225             }
5226         }
5227     }
5228     else {
5229         if (gimme == G_ARRAY)
5230             RETURN;
5231     }
5232     if (iters || !pm->op_pmreplroot) {
5233         GETTARGET;
5234         PUSHi(iters);
5235         RETURN;
5236     }
5237     RETPUSHUNDEF;
5238 }
5239
5240 #ifdef USE_THREADS
5241 void
5242 Perl_unlock_condpair(pTHX_ void *svv)
5243 {
5244     dTHR;
5245     MAGIC *mg = mg_find((SV*)svv, 'm');
5246
5247     if (!mg)
5248         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5249     MUTEX_LOCK(MgMUTEXP(mg));
5250     if (MgOWNER(mg) != thr)
5251         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5252     MgOWNER(mg) = 0;
5253     COND_SIGNAL(MgOWNERCONDP(mg));
5254     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5255                           PTR2UV(thr), PTR2UV(svv));)
5256     MUTEX_UNLOCK(MgMUTEXP(mg));
5257 }
5258 #endif /* USE_THREADS */
5259
5260 PP(pp_lock)
5261 {
5262     djSP;
5263     dTOPss;
5264     SV *retsv = sv;
5265 #ifdef USE_THREADS
5266     sv_lock(sv);
5267 #endif /* USE_THREADS */
5268     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5269         || SvTYPE(retsv) == SVt_PVCV) {
5270         retsv = refto(retsv);
5271     }
5272     SETs(retsv);
5273     RETURN;
5274 }
5275
5276 PP(pp_threadsv)
5277 {
5278 #ifdef USE_THREADS
5279     djSP;
5280     EXTEND(SP, 1);
5281     if (PL_op->op_private & OPpLVAL_INTRO)
5282         PUSHs(*save_threadsv(PL_op->op_targ));
5283     else
5284         PUSHs(THREADSV(PL_op->op_targ));
5285     RETURN;
5286 #else
5287     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5288 #endif /* USE_THREADS */
5289 }