pp.c

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