pp.c

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