pp.c

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