pp.c

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