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,len);
 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 (lvalue) {                   /* it's an lvalue! */
2025             if (!SvGMAGICAL(sv)) {
2026                 if (SvROK(sv)) {
2027                     STRLEN n_a;
2028                     SvPV_force(sv,n_a);
2029                     if (ckWARN(WARN_SUBSTR))
2030                         Perl_warner(aTHX_ WARN_SUBSTR,
2031                                 "Attempt to use reference as lvalue in substr");
2032                 }
2033                 if (SvOK(sv))           /* is it defined ? */
2034                     (void)SvPOK_only(sv);
2035                 else
2036                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2037             }
2038
2039             if (SvTYPE(TARG) < SVt_PVLV) {
2040                 sv_upgrade(TARG, SVt_PVLV);
2041                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2042             }
2043
2044             LvTYPE(TARG) = 'x';
2045             if (LvTARG(TARG) != sv) {
2046                 if (LvTARG(TARG))
2047                     SvREFCNT_dec(LvTARG(TARG));
2048                 LvTARG(TARG) = SvREFCNT_inc(sv);
2049             }
2050             LvTARGOFF(TARG) = pos;
2051             LvTARGLEN(TARG) = rem;
2052         }
2053         else if (repl)
2054             sv_insert(sv, pos, rem, repl, repl_len);
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) {
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)) {
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) {
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)) {
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)) {
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)) {
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         while (++MARK <= SP) {
2651             if (hvtype == SVt_PVHV)
2652                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2653             else
2654                 DIE(aTHX_ "Not a HASH reference");
2655             *MARK = sv ? sv : &PL_sv_undef;
2656         }
2657         if (discard)
2658             SP = ORIGMARK;
2659         else if (gimme == G_SCALAR) {
2660             MARK = ORIGMARK;
2661             *++MARK = *SP;
2662             SP = MARK;
2663         }
2664     }
2665     else {
2666         SV *keysv = POPs;
2667         hv = (HV*)POPs;
2668         if (SvTYPE(hv) == SVt_PVHV)
2669             sv = hv_delete_ent(hv, keysv, discard, 0);
2670         else
2671             DIE(aTHX_ "Not a HASH reference");
2672         if (!sv)
2673             sv = &PL_sv_undef;
2674         if (!discard)
2675             PUSHs(sv);
2676     }
2677     RETURN;
2678 }
2679
2680 PP(pp_exists)
2681 {
2682     djSP;
2683     SV *tmpsv = POPs;
2684     HV *hv = (HV*)POPs;
2685     if (SvTYPE(hv) == SVt_PVHV) {
2686         if (hv_exists_ent(hv, tmpsv, 0))
2687             RETPUSHYES;
2688     }
2689     else if (SvTYPE(hv) == SVt_PVAV) {
2690         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2691             RETPUSHYES;
2692     }
2693     else {
2694         DIE(aTHX_ "Not a HASH reference");
2695     }
2696     RETPUSHNO;
2697 }
2698
2699 PP(pp_hslice)
2700 {
2701     djSP; dMARK; dORIGMARK;
2702     register HV *hv = (HV*)POPs;
2703     register I32 lval = PL_op->op_flags & OPf_MOD;
2704     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2705
2706     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2707         DIE(aTHX_ "Can't localize pseudo-hash element");
2708
2709     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2710         while (++MARK <= SP) {
2711             SV *keysv = *MARK;
2712             SV **svp;
2713             if (realhv) {
2714                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2715                 svp = he ? &HeVAL(he) : 0;
2716             }
2717             else {
2718                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2719             }
2720             if (lval) {
2721                 if (!svp || *svp == &PL_sv_undef) {
2722                     STRLEN n_a;
2723                     DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2724                 }
2725                 if (PL_op->op_private & OPpLVAL_INTRO)
2726                     save_helem(hv, keysv, svp);
2727             }
2728             *MARK = svp ? *svp : &PL_sv_undef;
2729         }
2730     }
2731     if (GIMME != G_ARRAY) {
2732         MARK = ORIGMARK;
2733         *++MARK = *SP;
2734         SP = MARK;
2735     }
2736     RETURN;
2737 }
2738
2739 /* List operators. */
2740
2741 PP(pp_list)
2742 {
2743     djSP; dMARK;
2744     if (GIMME != G_ARRAY) {
2745         if (++MARK <= SP)
2746             *MARK = *SP;                /* unwanted list, return last item */
2747         else
2748             *MARK = &PL_sv_undef;
2749         SP = MARK;
2750     }
2751     RETURN;
2752 }
2753
2754 PP(pp_lslice)
2755 {
2756     djSP;
2757     SV **lastrelem = PL_stack_sp;
2758     SV **lastlelem = PL_stack_base + POPMARK;
2759     SV **firstlelem = PL_stack_base + POPMARK + 1;
2760     register SV **firstrelem = lastlelem + 1;
2761     I32 arybase = PL_curcop->cop_arybase;
2762     I32 lval = PL_op->op_flags & OPf_MOD;
2763     I32 is_something_there = lval;
2764
2765     register I32 max = lastrelem - lastlelem;
2766     register SV **lelem;
2767     register I32 ix;
2768
2769     if (GIMME != G_ARRAY) {
2770         ix = SvIVx(*lastlelem);
2771         if (ix < 0)
2772             ix += max;
2773         else
2774             ix -= arybase;
2775         if (ix < 0 || ix >= max)
2776             *firstlelem = &PL_sv_undef;
2777         else
2778             *firstlelem = firstrelem[ix];
2779         SP = firstlelem;
2780         RETURN;
2781     }
2782
2783     if (max == 0) {
2784         SP = firstlelem - 1;
2785         RETURN;
2786     }
2787
2788     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2789         ix = SvIVx(*lelem);
2790         if (ix < 0)
2791             ix += max;
2792         else
2793             ix -= arybase;
2794         if (ix < 0 || ix >= max)
2795             *lelem = &PL_sv_undef;
2796         else {
2797             is_something_there = TRUE;
2798             if (!(*lelem = firstrelem[ix]))
2799                 *lelem = &PL_sv_undef;
2800         }
2801     }
2802     if (is_something_there)
2803         SP = lastlelem;
2804     else
2805         SP = firstlelem - 1;
2806     RETURN;
2807 }
2808
2809 PP(pp_anonlist)
2810 {
2811     djSP; dMARK; dORIGMARK;
2812     I32 items = SP - MARK;
2813     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2814     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2815     XPUSHs(av);
2816     RETURN;
2817 }
2818
2819 PP(pp_anonhash)
2820 {
2821     djSP; dMARK; dORIGMARK;
2822     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2823
2824     while (MARK < SP) {
2825         SV* key = *++MARK;
2826         SV *val = NEWSV(46, 0);
2827         if (MARK < SP)
2828             sv_setsv(val, *++MARK);
2829         else if (ckWARN(WARN_UNSAFE))
2830             Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2831         (void)hv_store_ent(hv,key,val,0);
2832     }
2833     SP = ORIGMARK;
2834     XPUSHs((SV*)hv);
2835     RETURN;
2836 }
2837
2838 PP(pp_splice)
2839 {
2840     djSP; dMARK; dORIGMARK;
2841     register AV *ary = (AV*)*++MARK;
2842     register SV **src;
2843     register SV **dst;
2844     register I32 i;
2845     register I32 offset;
2846     register I32 length;
2847     I32 newlen;
2848     I32 after;
2849     I32 diff;
2850     SV **tmparyval = 0;
2851     MAGIC *mg;
2852
2853     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2854         *MARK-- = SvTIED_obj((SV*)ary, mg);
2855         PUSHMARK(MARK);
2856         PUTBACK;
2857         ENTER;
2858         call_method("SPLICE",GIMME_V);
2859         LEAVE;
2860         SPAGAIN;
2861         RETURN;
2862     }
2863
2864     SP++;
2865
2866     if (++MARK < SP) {
2867         offset = i = SvIVx(*MARK);
2868         if (offset < 0)
2869             offset += AvFILLp(ary) + 1;
2870         else
2871             offset -= PL_curcop->cop_arybase;
2872         if (offset < 0)
2873             DIE(aTHX_ PL_no_aelem, i);
2874         if (++MARK < SP) {
2875             length = SvIVx(*MARK++);
2876             if (length < 0) {
2877                 length += AvFILLp(ary) - offset + 1;
2878                 if (length < 0)
2879                     length = 0;
2880             }
2881         }
2882         else
2883             length = AvMAX(ary) + 1;            /* close enough to infinity */
2884     }
2885     else {
2886         offset = 0;
2887         length = AvMAX(ary) + 1;
2888     }
2889     if (offset > AvFILLp(ary) + 1)
2890         offset = AvFILLp(ary) + 1;
2891     after = AvFILLp(ary) + 1 - (offset + length);
2892     if (after < 0) {                            /* not that much array */
2893         length += after;                        /* offset+length now in array */
2894         after = 0;
2895         if (!AvALLOC(ary))
2896             av_extend(ary, 0);
2897     }
2898
2899     /* At this point, MARK .. SP-1 is our new LIST */
2900
2901     newlen = SP - MARK;
2902     diff = newlen - length;
2903     if (newlen && !AvREAL(ary) && AvREIFY(ary))
2904         av_reify(ary);
2905
2906     if (diff < 0) {                             /* shrinking the area */
2907         if (newlen) {
2908             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2909             Copy(MARK, tmparyval, newlen, SV*);
2910         }
2911
2912         MARK = ORIGMARK + 1;
2913         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2914             MEXTEND(MARK, length);
2915             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2916             if (AvREAL(ary)) {
2917                 EXTEND_MORTAL(length);
2918                 for (i = length, dst = MARK; i; i--) {
2919                     sv_2mortal(*dst);   /* free them eventualy */
2920                     dst++;
2921                 }
2922             }
2923             MARK += length - 1;
2924         }
2925         else {
2926             *MARK = AvARRAY(ary)[offset+length-1];
2927             if (AvREAL(ary)) {
2928                 sv_2mortal(*MARK);
2929                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2930                     SvREFCNT_dec(*dst++);       /* free them now */
2931             }
2932         }
2933         AvFILLp(ary) += diff;
2934
2935         /* pull up or down? */
2936
2937         if (offset < after) {                   /* easier to pull up */
2938             if (offset) {                       /* esp. if nothing to pull */
2939                 src = &AvARRAY(ary)[offset-1];
2940                 dst = src - diff;               /* diff is negative */
2941                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2942                     *dst-- = *src--;
2943             }
2944             dst = AvARRAY(ary);
2945             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2946             AvMAX(ary) += diff;
2947         }
2948         else {
2949             if (after) {                        /* anything to pull down? */
2950                 src = AvARRAY(ary) + offset + length;
2951                 dst = src + diff;               /* diff is negative */
2952                 Move(src, dst, after, SV*);
2953             }
2954             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2955                                                 /* avoid later double free */
2956         }
2957         i = -diff;
2958         while (i)
2959             dst[--i] = &PL_sv_undef;
2960
2961         if (newlen) {
2962             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2963               newlen; newlen--) {
2964                 *dst = NEWSV(46, 0);
2965                 sv_setsv(*dst++, *src++);
2966             }
2967             Safefree(tmparyval);
2968         }
2969     }
2970     else {                                      /* no, expanding (or same) */
2971         if (length) {
2972             New(452, tmparyval, length, SV*);   /* so remember deletion */
2973             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2974         }
2975
2976         if (diff > 0) {                         /* expanding */
2977
2978             /* push up or down? */
2979
2980             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2981                 if (offset) {
2982                     src = AvARRAY(ary);
2983                     dst = src - diff;
2984                     Move(src, dst, offset, SV*);
2985                 }
2986                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2987                 AvMAX(ary) += diff;
2988                 AvFILLp(ary) += diff;
2989             }
2990             else {
2991                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2992                     av_extend(ary, AvFILLp(ary) + diff);
2993                 AvFILLp(ary) += diff;
2994
2995                 if (after) {
2996                     dst = AvARRAY(ary) + AvFILLp(ary);
2997                     src = dst - diff;
2998                     for (i = after; i; i--) {
2999                         *dst-- = *src--;
3000                     }
3001                 }
3002             }
3003         }
3004
3005         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3006             *dst = NEWSV(46, 0);
3007             sv_setsv(*dst++, *src++);
3008         }
3009         MARK = ORIGMARK + 1;
3010         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
3011             if (length) {
3012                 Copy(tmparyval, MARK, length, SV*);
3013                 if (AvREAL(ary)) {
3014                     EXTEND_MORTAL(length);
3015                     for (i = length, dst = MARK; i; i--) {
3016                         sv_2mortal(*dst);       /* free them eventualy */
3017                         dst++;
3018                     }
3019                 }
3020                 Safefree(tmparyval);
3021             }
3022             MARK += length - 1;
3023         }
3024         else if (length--) {
3025             *MARK = tmparyval[length];
3026             if (AvREAL(ary)) {
3027                 sv_2mortal(*MARK);
3028                 while (length-- > 0)
3029                     SvREFCNT_dec(tmparyval[length]);
3030             }
3031             Safefree(tmparyval);
3032         }
3033         else
3034             *MARK = &PL_sv_undef;
3035     }
3036     SP = MARK;
3037     RETURN;
3038 }
3039
3040 PP(pp_push)
3041 {
3042     djSP; dMARK; dORIGMARK; dTARGET;
3043     register AV *ary = (AV*)*++MARK;
3044     register SV *sv = &PL_sv_undef;
3045     MAGIC *mg;
3046
3047     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3048         *MARK-- = SvTIED_obj((SV*)ary, mg);
3049         PUSHMARK(MARK);
3050         PUTBACK;
3051         ENTER;
3052         call_method("PUSH",G_SCALAR|G_DISCARD);
3053         LEAVE;
3054         SPAGAIN;
3055     }
3056     else {
3057         /* Why no pre-extend of ary here ? */
3058         for (++MARK; MARK <= SP; MARK++) {
3059             sv = NEWSV(51, 0);
3060             if (*MARK)
3061                 sv_setsv(sv, *MARK);
3062             av_push(ary, sv);
3063         }
3064     }
3065     SP = ORIGMARK;
3066     PUSHi( AvFILL(ary) + 1 );
3067     RETURN;
3068 }
3069
3070 PP(pp_pop)
3071 {
3072     djSP;
3073     AV *av = (AV*)POPs;
3074     SV *sv = av_pop(av);
3075     if (AvREAL(av))
3076         (void)sv_2mortal(sv);
3077     PUSHs(sv);
3078     RETURN;
3079 }
3080
3081 PP(pp_shift)
3082 {
3083     djSP;
3084     AV *av = (AV*)POPs;
3085     SV *sv = av_shift(av);
3086     EXTEND(SP, 1);
3087     if (!sv)
3088         RETPUSHUNDEF;
3089     if (AvREAL(av))
3090         (void)sv_2mortal(sv);
3091     PUSHs(sv);
3092     RETURN;
3093 }
3094
3095 PP(pp_unshift)
3096 {
3097     djSP; dMARK; dORIGMARK; dTARGET;
3098     register AV *ary = (AV*)*++MARK;
3099     register SV *sv;
3100     register I32 i = 0;
3101     MAGIC *mg;
3102
3103     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3104         *MARK-- = SvTIED_obj((SV*)ary, mg);
3105         PUSHMARK(MARK);
3106         PUTBACK;
3107         ENTER;
3108         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3109         LEAVE;
3110         SPAGAIN;
3111     }
3112     else {
3113         av_unshift(ary, SP - MARK);
3114         while (MARK < SP) {
3115             sv = NEWSV(27, 0);
3116             sv_setsv(sv, *++MARK);
3117             (void)av_store(ary, i++, sv);
3118         }
3119     }
3120     SP = ORIGMARK;
3121     PUSHi( AvFILL(ary) + 1 );
3122     RETURN;
3123 }
3124
3125 PP(pp_reverse)
3126 {
3127     djSP; dMARK;
3128     register SV *tmp;
3129     SV **oldsp = SP;
3130
3131     if (GIMME == G_ARRAY) {
3132         MARK++;
3133         while (MARK < SP) {
3134             tmp = *MARK;
3135             *MARK++ = *SP;
3136             *SP-- = tmp;
3137         }
3138         /* safe as long as stack cannot get extended in the above */
3139         SP = oldsp;
3140     }
3141     else {
3142         register char *up;
3143         register char *down;
3144         register I32 tmp;
3145         dTARGET;
3146         STRLEN len;
3147
3148         if (SP - MARK > 1)
3149             do_join(TARG, &PL_sv_no, MARK, SP);
3150         else
3151             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3152         up = SvPV_force(TARG, len);
3153         if (len > 1) {
3154             if (IN_UTF8) {      /* first reverse each character */
3155                 U8* s = (U8*)SvPVX(TARG);
3156                 U8* send = (U8*)(s + len);
3157                 while (s < send) {
3158                     if (*s < 0x80) {
3159                         s++;
3160                         continue;
3161                     }
3162                     else {
3163                         up = (char*)s;
3164                         s += UTF8SKIP(s);
3165                         down = (char*)(s - 1);
3166                         if (s > send || !((*down & 0xc0) == 0x80)) {
3167                             if (ckWARN_d(WARN_UTF8))
3168                                 Perl_warner(aTHX_ WARN_UTF8,
3169                                             "Malformed UTF-8 character");
3170                             break;
3171                         }
3172                         while (down > up) {
3173                             tmp = *up;
3174                             *up++ = *down;
3175                             *down-- = tmp;
3176                         }
3177                     }
3178                 }
3179                 up = SvPVX(TARG);
3180             }
3181             down = SvPVX(TARG) + len - 1;
3182             while (down > up) {
3183                 tmp = *up;
3184                 *up++ = *down;
3185                 *down-- = tmp;
3186             }
3187             (void)SvPOK_only(TARG);
3188         }
3189         SP = MARK + 1;
3190         SETTARG;
3191     }
3192     RETURN;
3193 }
3194
3195 STATIC SV *
3196 S_mul128(pTHX_ SV *sv, U8 m)
3197 {
3198   STRLEN          len;
3199   char           *s = SvPV(sv, len);
3200   char           *t;
3201   U32             i = 0;
3202
3203   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3204     SV             *tmpNew = newSVpvn("0000000000", 10);
3205
3206     sv_catsv(tmpNew, sv);
3207     SvREFCNT_dec(sv);           /* free old sv */
3208     sv = tmpNew;
3209     s = SvPV(sv, len);
3210   }
3211   t = s + len - 1;
3212   while (!*t)                   /* trailing '\0'? */
3213     t--;
3214   while (t > s) {
3215     i = ((*t - '0') << 7) + m;
3216     *(t--) = '0' + (i % 10);
3217     m = i / 10;
3218   }
3219   return (sv);
3220 }
3221
3222 /* Explosives and implosives. */
3223
3224 #if 'I' == 73 && 'J' == 74
3225 /* On an ASCII/ISO kind of system */
3226 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3227 #else
3228 /*
3229   Some other sort of character set - use memchr() so we don't match
3230   the null byte.
3231  */
3232 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3233 #endif
3234
3235 PP(pp_unpack)
3236 {
3237     djSP;
3238     dPOPPOPssrl;
3239     I32 start_sp_offset = SP - PL_stack_base;
3240     I32 gimme = GIMME_V;
3241     SV *sv;
3242     STRLEN llen;
3243     STRLEN rlen;
3244     register char *pat = SvPV(left, llen);
3245     register char *s = SvPV(right, rlen);
3246     char *strend = s + rlen;
3247     char *strbeg = s;
3248     register char *patend = pat + llen;
3249     I32 datumtype;
3250     register I32 len;
3251     register I32 bits;
3252
3253     /* These must not be in registers: */
3254     I16 ashort;
3255     int aint;
3256     I32 along;
3257 #ifdef HAS_QUAD
3258     Quad_t aquad;
3259 #endif
3260     U16 aushort;
3261     unsigned int auint;
3262     U32 aulong;
3263 #ifdef HAS_QUAD
3264     Uquad_t auquad;
3265 #endif
3266     char *aptr;
3267     float afloat;
3268     double adouble;
3269     I32 checksum = 0;
3270     register U32 culong;
3271     NV cdouble;
3272     int commas = 0;
3273     int star;
3274 #ifdef PERL_NATINT_PACK
3275     int natint;         /* native integer */
3276     int unatint;        /* unsigned native integer */
3277 #endif
3278
3279     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3280         /*SUPPRESS 530*/
3281         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3282         if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3283             patend++;
3284             while (isDIGIT(*patend) || *patend == '*')
3285                 patend++;
3286         }
3287         else
3288             patend++;
3289     }
3290     while (pat < patend) {
3291       reparse:
3292         datumtype = *pat++ & 0xFF;
3293 #ifdef PERL_NATINT_PACK
3294         natint = 0;
3295 #endif
3296         if (isSPACE(datumtype))
3297             continue;
3298         if (datumtype == '#') {
3299             while (pat < patend && *pat != '\n')
3300                 pat++;
3301             continue;
3302         }
3303         if (*pat == '!') {
3304             char *natstr = "sSiIlL";
3305
3306             if (strchr(natstr, datumtype)) {
3307 #ifdef PERL_NATINT_PACK
3308                 natint = 1;
3309 #endif
3310                 pat++;
3311             }
3312             else
3313                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3314         }
3315         star = 0;
3316         if (pat >= patend)
3317             len = 1;
3318         else if (*pat == '*') {
3319             len = strend - strbeg;      /* long enough */
3320             pat++;
3321             star = 1;
3322         }
3323         else if (isDIGIT(*pat)) {
3324             len = *pat++ - '0';
3325             while (isDIGIT(*pat)) {
3326                 len = (len * 10) + (*pat++ - '0');
3327                 if (len < 0)
3328                     DIE(aTHX_ "Repeat count in unpack overflows");
3329             }
3330         }
3331         else
3332             len = (datumtype != '@');
3333       redo_switch:
3334         switch(datumtype) {
3335         default:
3336             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3337         case ',': /* grandfather in commas but with a warning */
3338             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3339                 Perl_warner(aTHX_ WARN_UNSAFE,
3340                             "Invalid type in unpack: '%c'", (int)datumtype);
3341             break;
3342         case '%':
3343             if (len == 1 && pat[-1] != '1')
3344                 len = 16;
3345             checksum = len;
3346             culong = 0;
3347             cdouble = 0;
3348             if (pat < patend)
3349                 goto reparse;
3350             break;
3351         case '@':
3352             if (len > strend - strbeg)
3353                 DIE(aTHX_ "@ outside of string");
3354             s = strbeg + len;
3355             break;
3356         case 'X':
3357             if (len > s - strbeg)
3358                 DIE(aTHX_ "X outside of string");
3359             s -= len;
3360             break;
3361         case 'x':
3362             if (len > strend - s)
3363                 DIE(aTHX_ "x outside of string");
3364             s += len;
3365             break;
3366         case '/':
3367             if (start_sp_offset >= SP - PL_stack_base)
3368                 DIE(aTHX_ "/ must follow a numeric type");
3369             datumtype = *pat++;
3370             if (*pat == '*')
3371                 pat++;          /* ignore '*' for compatibility with pack */
3372             if (isDIGIT(*pat))
3373                 DIE(aTHX_ "/ cannot take a count" );
3374             len = POPi;
3375             star = 0;
3376             goto redo_switch;
3377         case 'A':
3378         case 'Z':
3379         case 'a':
3380             if (len > strend - s)
3381                 len = strend - s;
3382             if (checksum)
3383                 goto uchar_checksum;
3384             sv = NEWSV(35, len);
3385             sv_setpvn(sv, s, len);
3386             s += len;
3387             if (datumtype == 'A' || datumtype == 'Z') {
3388                 aptr = s;       /* borrow register */
3389                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3390                     s = SvPVX(sv);
3391                     while (*s)
3392                         s++;
3393                 }
3394                 else {          /* 'A' strips both nulls and spaces */
3395                     s = SvPVX(sv) + len - 1;
3396                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3397                         s--;
3398                     *++s = '\0';
3399                 }
3400                 SvCUR_set(sv, s - SvPVX(sv));
3401                 s = aptr;       /* unborrow register */
3402             }
3403             XPUSHs(sv_2mortal(sv));
3404             break;
3405         case 'B':
3406         case 'b':
3407             if (star || len > (strend - s) * 8)
3408                 len = (strend - s) * 8;
3409             if (checksum) {
3410                 if (!PL_bitcount) {
3411                     Newz(601, PL_bitcount, 256, char);
3412                     for (bits = 1; bits < 256; bits++) {
3413                         if (bits & 1)   PL_bitcount[bits]++;
3414                         if (bits & 2)   PL_bitcount[bits]++;
3415                         if (bits & 4)   PL_bitcount[bits]++;
3416                         if (bits & 8)   PL_bitcount[bits]++;
3417                         if (bits & 16)  PL_bitcount[bits]++;
3418                         if (bits & 32)  PL_bitcount[bits]++;
3419                         if (bits & 64)  PL_bitcount[bits]++;
3420                         if (bits & 128) PL_bitcount[bits]++;
3421                     }
3422                 }
3423                 while (len >= 8) {
3424                     culong += PL_bitcount[*(unsigned char*)s++];
3425                     len -= 8;
3426                 }
3427                 if (len) {
3428                     bits = *s;
3429                     if (datumtype == 'b') {
3430                         while (len-- > 0) {
3431                             if (bits & 1) culong++;
3432                             bits >>= 1;
3433                         }
3434                     }
3435                     else {
3436                         while (len-- > 0) {
3437                             if (bits & 128) culong++;
3438                             bits <<= 1;
3439                         }
3440                     }
3441                 }
3442                 break;
3443             }
3444             sv = NEWSV(35, len + 1);
3445             SvCUR_set(sv, len);
3446             SvPOK_on(sv);
3447             aptr = pat;                 /* borrow register */
3448             pat = SvPVX(sv);
3449             if (datumtype == 'b') {
3450                 aint = len;
3451                 for (len = 0; len < aint; len++) {
3452                     if (len & 7)                /*SUPPRESS 595*/
3453                         bits >>= 1;
3454                     else
3455                         bits = *s++;
3456                     *pat++ = '0' + (bits & 1);
3457                 }
3458             }
3459             else {
3460                 aint = len;
3461                 for (len = 0; len < aint; len++) {
3462                     if (len & 7)
3463                         bits <<= 1;
3464                     else
3465                         bits = *s++;
3466                     *pat++ = '0' + ((bits & 128) != 0);
3467                 }
3468             }
3469             *pat = '\0';
3470             pat = aptr;                 /* unborrow register */
3471             XPUSHs(sv_2mortal(sv));
3472             break;
3473         case 'H':
3474         case 'h':
3475             if (star || len > (strend - s) * 2)
3476                 len = (strend - s) * 2;
3477             sv = NEWSV(35, len + 1);
3478             SvCUR_set(sv, len);
3479             SvPOK_on(sv);
3480             aptr = pat;                 /* borrow register */
3481             pat = SvPVX(sv);
3482             if (datumtype == 'h') {
3483                 aint = len;
3484                 for (len = 0; len < aint; len++) {
3485                     if (len & 1)
3486                         bits >>= 4;
3487                     else
3488                         bits = *s++;
3489                     *pat++ = PL_hexdigit[bits & 15];
3490                 }
3491             }
3492             else {
3493                 aint = len;
3494                 for (len = 0; len < aint; len++) {
3495                     if (len & 1)
3496                         bits <<= 4;
3497                     else
3498                         bits = *s++;
3499                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3500                 }
3501             }
3502             *pat = '\0';
3503             pat = aptr;                 /* unborrow register */
3504             XPUSHs(sv_2mortal(sv));
3505             break;
3506         case 'c':
3507             if (len > strend - s)
3508                 len = strend - s;
3509             if (checksum) {
3510                 while (len-- > 0) {
3511                     aint = *s++;
3512                     if (aint >= 128)    /* fake up signed chars */
3513                         aint -= 256;
3514                     culong += aint;
3515                 }
3516             }
3517             else {
3518                 EXTEND(SP, len);
3519                 EXTEND_MORTAL(len);
3520                 while (len-- > 0) {
3521                     aint = *s++;
3522                     if (aint >= 128)    /* fake up signed chars */
3523                         aint -= 256;
3524                     sv = NEWSV(36, 0);
3525                     sv_setiv(sv, (IV)aint);
3526                     PUSHs(sv_2mortal(sv));
3527                 }
3528             }
3529             break;
3530         case 'C':
3531             if (len > strend - s)
3532                 len = strend - s;
3533             if (checksum) {
3534               uchar_checksum:
3535                 while (len-- > 0) {
3536                     auint = *s++ & 255;
3537                     culong += auint;
3538                 }
3539             }
3540             else {
3541                 EXTEND(SP, len);
3542                 EXTEND_MORTAL(len);
3543                 while (len-- > 0) {
3544                     auint = *s++ & 255;
3545                     sv = NEWSV(37, 0);
3546                     sv_setiv(sv, (IV)auint);
3547                     PUSHs(sv_2mortal(sv));
3548                 }
3549             }
3550             break;
3551         case 'U':
3552             if (len > strend - s)
3553                 len = strend - s;
3554             if (checksum) {
3555                 while (len-- > 0 && s < strend) {
3556                     auint = utf8_to_uv((U8*)s, &along);
3557                     s += along;
3558                     if (checksum > 32)
3559                         cdouble += (NV)auint;
3560                     else
3561                         culong += auint;
3562                 }
3563             }
3564             else {
3565                 EXTEND(SP, len);
3566                 EXTEND_MORTAL(len);
3567                 while (len-- > 0 && s < strend) {
3568                     auint = utf8_to_uv((U8*)s, &along);
3569                     s += along;
3570                     sv = NEWSV(37, 0);
3571                     sv_setuv(sv, (UV)auint);
3572                     PUSHs(sv_2mortal(sv));
3573                 }
3574             }
3575             break;
3576         case 's':
3577 #if SHORTSIZE == SIZE16
3578             along = (strend - s) / SIZE16;
3579 #else
3580             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3581 #endif
3582             if (len > along)
3583                 len = along;
3584             if (checksum) {
3585 #if SHORTSIZE != SIZE16
3586                 if (natint) {
3587                     short ashort;
3588                     while (len-- > 0) {
3589                         COPYNN(s, &ashort, sizeof(short));
3590                         s += sizeof(short);
3591                         culong += ashort;
3592
3593                     }
3594                 }
3595                 else
3596 #endif
3597                 {
3598                     while (len-- > 0) {
3599                         COPY16(s, &ashort);
3600 #if SHORTSIZE > SIZE16
3601                         if (ashort > 32767)
3602                           ashort -= 65536;
3603 #endif
3604                         s += SIZE16;
3605                         culong += ashort;
3606                     }
3607                 }
3608             }
3609             else {
3610                 EXTEND(SP, len);
3611                 EXTEND_MORTAL(len);
3612 #if SHORTSIZE != SIZE16
3613                 if (natint) {
3614                     short ashort;
3615                     while (len-- > 0) {
3616                         COPYNN(s, &ashort, sizeof(short));
3617                         s += sizeof(short);
3618                         sv = NEWSV(38, 0);
3619                         sv_setiv(sv, (IV)ashort);
3620                         PUSHs(sv_2mortal(sv));
3621                     }
3622                 }
3623                 else
3624 #endif
3625                 {
3626                     while (len-- > 0) {
3627                         COPY16(s, &ashort);
3628 #if SHORTSIZE > SIZE16
3629                         if (ashort > 32767)
3630                           ashort -= 65536;
3631 #endif
3632                         s += SIZE16;
3633                         sv = NEWSV(38, 0);
3634                         sv_setiv(sv, (IV)ashort);
3635                         PUSHs(sv_2mortal(sv));
3636                     }
3637                 }
3638             }
3639             break;
3640         case 'v':
3641         case 'n':
3642         case 'S':
3643 #if SHORTSIZE == SIZE16
3644             along = (strend - s) / SIZE16;
3645 #else
3646             unatint = natint && datumtype == 'S';
3647             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3648 #endif
3649             if (len > along)
3650                 len = along;
3651             if (checksum) {
3652 #if SHORTSIZE != SIZE16
3653                 if (unatint) {
3654                     unsigned short aushort;
3655                     while (len-- > 0) {
3656                         COPYNN(s, &aushort, sizeof(unsigned short));
3657                         s += sizeof(unsigned short);
3658                         culong += aushort;
3659                     }
3660                 }
3661                 else
3662 #endif
3663                 {
3664                     while (len-- > 0) {
3665                         COPY16(s, &aushort);
3666                         s += SIZE16;
3667 #ifdef HAS_NTOHS
3668                         if (datumtype == 'n')
3669                             aushort = PerlSock_ntohs(aushort);
3670 #endif
3671 #ifdef HAS_VTOHS
3672                         if (datumtype == 'v')
3673                             aushort = vtohs(aushort);
3674 #endif
3675                         culong += aushort;
3676                     }
3677                 }
3678             }
3679             else {
3680                 EXTEND(SP, len);
3681                 EXTEND_MORTAL(len);
3682 #if SHORTSIZE != SIZE16
3683                 if (unatint) {
3684                     unsigned short aushort;
3685                     while (len-- > 0) {
3686                         COPYNN(s, &aushort, sizeof(unsigned short));
3687                         s += sizeof(unsigned short);
3688                         sv = NEWSV(39, 0);
3689                         sv_setiv(sv, (UV)aushort);
3690                         PUSHs(sv_2mortal(sv));
3691                     }
3692                 }
3693                 else
3694 #endif
3695                 {
3696                     while (len-- > 0) {
3697                         COPY16(s, &aushort);
3698                         s += SIZE16;
3699                         sv = NEWSV(39, 0);
3700 #ifdef HAS_NTOHS
3701                         if (datumtype == 'n')
3702                             aushort = PerlSock_ntohs(aushort);
3703 #endif
3704 #ifdef HAS_VTOHS
3705                         if (datumtype == 'v')
3706                             aushort = vtohs(aushort);
3707 #endif
3708                         sv_setiv(sv, (UV)aushort);
3709                         PUSHs(sv_2mortal(sv));
3710                     }
3711                 }
3712             }
3713             break;
3714         case 'i':
3715             along = (strend - s) / sizeof(int);
3716             if (len > along)
3717                 len = along;
3718             if (checksum) {
3719                 while (len-- > 0) {
3720                     Copy(s, &aint, 1, int);
3721                     s += sizeof(int);
3722                     if (checksum > 32)
3723                         cdouble += (NV)aint;
3724                     else
3725                         culong += aint;
3726                 }
3727             }
3728             else {
3729                 EXTEND(SP, len);
3730                 EXTEND_MORTAL(len);
3731                 while (len-- > 0) {
3732                     Copy(s, &aint, 1, int);
3733                     s += sizeof(int);
3734                     sv = NEWSV(40, 0);
3735 #ifdef __osf__
3736                     /* Without the dummy below unpack("i", pack("i",-1))
3737                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3738                      * cc with optimization turned on.
3739                      *
3740                      * The bug was detected in
3741                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3742                      * with optimization (-O4) turned on.
3743                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3744                      * does not have this problem even with -O4.
3745                      *
3746                      * This bug was reported as DECC_BUGS 1431
3747                      * and tracked internally as GEM_BUGS 7775.
3748                      *
3749                      * The bug is fixed in
3750                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3751                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3752                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3753                      * and also in DTK.
3754                      *
3755                      * See also few lines later for the same bug.
3756                      */
3757                     (aint) ?
3758                         sv_setiv(sv, (IV)aint) :
3759 #endif
3760                     sv_setiv(sv, (IV)aint);
3761                     PUSHs(sv_2mortal(sv));
3762                 }
3763             }
3764             break;
3765         case 'I':
3766             along = (strend - s) / sizeof(unsigned int);
3767             if (len > along)
3768                 len = along;
3769             if (checksum) {
3770                 while (len-- > 0) {
3771                     Copy(s, &auint, 1, unsigned int);
3772                     s += sizeof(unsigned int);
3773                     if (checksum > 32)
3774                         cdouble += (NV)auint;
3775                     else
3776                         culong += auint;
3777                 }
3778             }
3779             else {
3780                 EXTEND(SP, len);
3781                 EXTEND_MORTAL(len);
3782                 while (len-- > 0) {
3783                     Copy(s, &auint, 1, unsigned int);
3784                     s += sizeof(unsigned int);
3785                     sv = NEWSV(41, 0);
3786 #ifdef __osf__
3787                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3788                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3789                      * See details few lines earlier. */
3790                     (auint) ?
3791                         sv_setuv(sv, (UV)auint) :
3792 #endif
3793                     sv_setuv(sv, (UV)auint);
3794                     PUSHs(sv_2mortal(sv));
3795                 }
3796             }
3797             break;
3798         case 'l':
3799 #if LONGSIZE == SIZE32
3800             along = (strend - s) / SIZE32;
3801 #else
3802             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3803 #endif
3804             if (len > along)
3805                 len = along;
3806             if (checksum) {
3807 #if LONGSIZE != SIZE32
3808                 if (natint) {
3809                     long along;
3810                     while (len-- > 0) {
3811                         COPYNN(s, &along, sizeof(long));
3812                         s += sizeof(long);
3813                         if (checksum > 32)
3814                             cdouble += (NV)along;
3815                         else
3816                             culong += along;
3817                     }
3818                 }
3819                 else
3820 #endif
3821                 {
3822                     while (len-- > 0) {
3823                         COPY32(s, &along);
3824 #if LONGSIZE > SIZE32
3825                         if (along > 2147483647)
3826                           along -= 4294967296;
3827 #endif
3828                         s += SIZE32;
3829                         if (checksum > 32)
3830                             cdouble += (NV)along;
3831                         else
3832                             culong += along;
3833                     }
3834                 }
3835             }
3836             else {
3837                 EXTEND(SP, len);
3838                 EXTEND_MORTAL(len);
3839 #if LONGSIZE != SIZE32
3840                 if (natint) {
3841                     long along;
3842                     while (len-- > 0) {
3843                         COPYNN(s, &along, sizeof(long));
3844                         s += sizeof(long);
3845                         sv = NEWSV(42, 0);
3846                         sv_setiv(sv, (IV)along);
3847                         PUSHs(sv_2mortal(sv));
3848                     }
3849                 }
3850                 else
3851 #endif
3852                 {
3853                     while (len-- > 0) {
3854                         COPY32(s, &along);
3855 #if LONGSIZE > SIZE32
3856                         if (along > 2147483647)
3857                           along -= 4294967296;
3858 #endif
3859                         s += SIZE32;
3860                         sv = NEWSV(42, 0);
3861                         sv_setiv(sv, (IV)along);
3862                         PUSHs(sv_2mortal(sv));
3863                     }
3864                 }
3865             }
3866             break;
3867         case 'V':
3868         case 'N':
3869         case 'L':
3870 #if LONGSIZE == SIZE32
3871             along = (strend - s) / SIZE32;
3872 #else
3873             unatint = natint && datumtype == 'L';
3874             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3875 #endif
3876             if (len > along)
3877                 len = along;
3878             if (checksum) {
3879 #if LONGSIZE != SIZE32
3880                 if (unatint) {
3881                     unsigned long aulong;
3882                     while (len-- > 0) {
3883                         COPYNN(s, &aulong, sizeof(unsigned long));
3884                         s += sizeof(unsigned long);
3885                         if (checksum > 32)
3886                             cdouble += (NV)aulong;
3887                         else
3888                             culong += aulong;
3889                     }
3890                 }
3891                 else
3892 #endif
3893                 {
3894                     while (len-- > 0) {
3895                         COPY32(s, &aulong);
3896                         s += SIZE32;
3897 #ifdef HAS_NTOHL
3898                         if (datumtype == 'N')
3899                             aulong = PerlSock_ntohl(aulong);
3900 #endif
3901 #ifdef HAS_VTOHL
3902                         if (datumtype == 'V')
3903                             aulong = vtohl(aulong);
3904 #endif
3905                         if (checksum > 32)
3906                             cdouble += (NV)aulong;
3907                         else
3908                             culong += aulong;
3909                     }
3910                 }
3911             }
3912             else {
3913                 EXTEND(SP, len);
3914                 EXTEND_MORTAL(len);
3915 #if LONGSIZE != SIZE32
3916                 if (unatint) {
3917                     unsigned long aulong;
3918                     while (len-- > 0) {
3919                         COPYNN(s, &aulong, sizeof(unsigned long));
3920                         s += sizeof(unsigned long);
3921                         sv = NEWSV(43, 0);
3922                         sv_setuv(sv, (UV)aulong);
3923                         PUSHs(sv_2mortal(sv));
3924                     }
3925                 }
3926                 else
3927 #endif
3928                 {
3929                     while (len-- > 0) {
3930                         COPY32(s, &aulong);
3931                         s += SIZE32;
3932 #ifdef HAS_NTOHL
3933                         if (datumtype == 'N')
3934                             aulong = PerlSock_ntohl(aulong);
3935 #endif
3936 #ifdef HAS_VTOHL
3937                         if (datumtype == 'V')
3938                             aulong = vtohl(aulong);
3939 #endif
3940                         sv = NEWSV(43, 0);
3941                         sv_setuv(sv, (UV)aulong);
3942                         PUSHs(sv_2mortal(sv));
3943                     }
3944                 }
3945             }
3946             break;
3947         case 'p':
3948             along = (strend - s) / sizeof(char*);
3949             if (len > along)
3950                 len = along;
3951             EXTEND(SP, len);
3952             EXTEND_MORTAL(len);
3953             while (len-- > 0) {
3954                 if (sizeof(char*) > strend - s)
3955                     break;
3956                 else {
3957                     Copy(s, &aptr, 1, char*);
3958                     s += sizeof(char*);
3959                 }
3960                 sv = NEWSV(44, 0);
3961                 if (aptr)
3962                     sv_setpv(sv, aptr);
3963                 PUSHs(sv_2mortal(sv));
3964             }
3965             break;
3966         case 'w':
3967             EXTEND(SP, len);
3968             EXTEND_MORTAL(len);
3969             {
3970                 UV auv = 0;
3971                 U32 bytes = 0;
3972
3973                 while ((len > 0) && (s < strend)) {
3974                     auv = (auv << 7) | (*s & 0x7f);
3975                     if (!(*s++ & 0x80)) {
3976                         bytes = 0;
3977                         sv = NEWSV(40, 0);
3978                         sv_setuv(sv, auv);
3979                         PUSHs(sv_2mortal(sv));
3980                         len--;
3981                         auv = 0;
3982                     }
3983                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3984                         char *t;
3985                         STRLEN n_a;
3986
3987                         sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3988                         while (s < strend) {
3989                             sv = mul128(sv, *s & 0x7f);
3990                             if (!(*s++ & 0x80)) {
3991                                 bytes = 0;
3992                                 break;
3993                             }
3994                         }
3995                         t = SvPV(sv, n_a);
3996                         while (*t == '0')
3997                             t++;
3998                         sv_chop(sv, t);
3999                         PUSHs(sv_2mortal(sv));
4000                         len--;
4001                         auv = 0;
4002                     }
4003                 }
4004                 if ((s >= strend) && bytes)
4005                     DIE(aTHX_ "Unterminated compressed integer");
4006             }
4007             break;
4008         case 'P':
4009             EXTEND(SP, 1);
4010             if (sizeof(char*) > strend - s)
4011                 break;
4012             else {
4013                 Copy(s, &aptr, 1, char*);
4014                 s += sizeof(char*);
4015             }
4016             sv = NEWSV(44, 0);
4017             if (aptr)
4018                 sv_setpvn(sv, aptr, len);
4019             PUSHs(sv_2mortal(sv));
4020             break;
4021 #ifdef HAS_QUAD
4022         case 'q':
4023             along = (strend - s) / sizeof(Quad_t);
4024             if (len > along)
4025                 len = along;
4026             EXTEND(SP, len);
4027             EXTEND_MORTAL(len);
4028             while (len-- > 0) {
4029                 if (s + sizeof(Quad_t) > strend)
4030                     aquad = 0;
4031                 else {
4032                     Copy(s, &aquad, 1, Quad_t);
4033                     s += sizeof(Quad_t);
4034                 }
4035                 sv = NEWSV(42, 0);
4036                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4037                     sv_setiv(sv, (IV)aquad);
4038                 else
4039                     sv_setnv(sv, (NV)aquad);
4040                 PUSHs(sv_2mortal(sv));
4041             }
4042             break;
4043         case 'Q':
4044             along = (strend - s) / sizeof(Quad_t);
4045             if (len > along)
4046                 len = along;
4047             EXTEND(SP, len);
4048             EXTEND_MORTAL(len);
4049             while (len-- > 0) {
4050                 if (s + sizeof(Uquad_t) > strend)
4051                     auquad = 0;
4052                 else {
4053                     Copy(s, &auquad, 1, Uquad_t);
4054                     s += sizeof(Uquad_t);
4055                 }
4056                 sv = NEWSV(43, 0);
4057                 if (auquad <= UV_MAX)
4058                     sv_setuv(sv, (UV)auquad);
4059                 else
4060                     sv_setnv(sv, (NV)auquad);
4061                 PUSHs(sv_2mortal(sv));
4062             }
4063             break;
4064 #endif
4065         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4066         case 'f':
4067         case 'F':
4068             along = (strend - s) / sizeof(float);
4069             if (len > along)
4070                 len = along;
4071             if (checksum) {
4072                 while (len-- > 0) {
4073                     Copy(s, &afloat, 1, float);
4074                     s += sizeof(float);
4075                     cdouble += afloat;
4076                 }
4077             }
4078             else {
4079                 EXTEND(SP, len);
4080                 EXTEND_MORTAL(len);
4081                 while (len-- > 0) {
4082                     Copy(s, &afloat, 1, float);
4083                     s += sizeof(float);
4084                     sv = NEWSV(47, 0);
4085                     sv_setnv(sv, (NV)afloat);
4086                     PUSHs(sv_2mortal(sv));
4087                 }
4088             }
4089             break;
4090         case 'd':
4091         case 'D':
4092             along = (strend - s) / sizeof(double);
4093             if (len > along)
4094                 len = along;
4095             if (checksum) {
4096                 while (len-- > 0) {
4097                     Copy(s, &adouble, 1, double);
4098                     s += sizeof(double);
4099                     cdouble += adouble;
4100                 }
4101             }
4102             else {
4103                 EXTEND(SP, len);
4104                 EXTEND_MORTAL(len);
4105                 while (len-- > 0) {
4106                     Copy(s, &adouble, 1, double);
4107                     s += sizeof(double);
4108                     sv = NEWSV(48, 0);
4109                     sv_setnv(sv, (NV)adouble);
4110                     PUSHs(sv_2mortal(sv));
4111                 }
4112             }
4113             break;
4114         case 'u':
4115             /* MKS:
4116              * Initialise the decode mapping.  By using a table driven
4117              * algorithm, the code will be character-set independent
4118              * (and just as fast as doing character arithmetic)
4119              */
4120             if (PL_uudmap['M'] == 0) {
4121                 int i;
4122
4123                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4124                     PL_uudmap[PL_uuemap[i]] = i;
4125                 /*
4126                  * Because ' ' and '`' map to the same value,
4127                  * we need to decode them both the same.
4128                  */
4129                 PL_uudmap[' '] = 0;
4130             }
4131
4132             along = (strend - s) * 3 / 4;
4133             sv = NEWSV(42, along);
4134             if (along)
4135                 SvPOK_on(sv);
4136             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4137                 I32 a, b, c, d;
4138                 char hunk[4];
4139
4140                 hunk[3] = '\0';
4141                 len = PL_uudmap[*s++] & 077;
4142                 while (len > 0) {
4143                     if (s < strend && ISUUCHAR(*s))
4144                         a = PL_uudmap[*s++] & 077;
4145                     else
4146                         a = 0;
4147                     if (s < strend && ISUUCHAR(*s))
4148                         b = PL_uudmap[*s++] & 077;
4149                     else
4150                         b = 0;
4151                     if (s < strend && ISUUCHAR(*s))
4152                         c = PL_uudmap[*s++] & 077;
4153                     else
4154                         c = 0;
4155                     if (s < strend && ISUUCHAR(*s))
4156                         d = PL_uudmap[*s++] & 077;
4157                     else
4158                         d = 0;
4159                     hunk[0] = (a << 2) | (b >> 4);
4160                     hunk[1] = (b << 4) | (c >> 2);
4161                     hunk[2] = (c << 6) | d;
4162                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4163                     len -= 3;
4164                 }
4165                 if (*s == '\n')
4166                     s++;
4167                 else if (s[1] == '\n')          /* possible checksum byte */
4168                     s += 2;
4169             }
4170             XPUSHs(sv_2mortal(sv));
4171             break;
4172         }
4173         if (checksum) {
4174             sv = NEWSV(42, 0);
4175             if (strchr("fFdD", datumtype) ||
4176               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4177                 NV trouble;
4178
4179                 adouble = 1.0;
4180                 while (checksum >= 16) {
4181                     checksum -= 16;
4182                     adouble *= 65536.0;
4183                 }
4184                 while (checksum >= 4) {
4185                     checksum -= 4;
4186                     adouble *= 16.0;
4187                 }
4188                 while (checksum--)
4189                     adouble *= 2.0;
4190                 along = (1 << checksum) - 1;
4191                 while (cdouble < 0.0)
4192                     cdouble += adouble;
4193                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4194                 sv_setnv(sv, cdouble);
4195             }
4196             else {
4197                 if (checksum < 32) {
4198                     aulong = (1 << checksum) - 1;
4199                     culong &= aulong;
4200                 }
4201                 sv_setuv(sv, (UV)culong);
4202             }
4203             XPUSHs(sv_2mortal(sv));
4204             checksum = 0;
4205         }
4206     }
4207     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4208         PUSHs(&PL_sv_undef);
4209     RETURN;
4210 }
4211
4212 STATIC void
4213 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4214 {
4215     char hunk[5];
4216
4217     *hunk = PL_uuemap[len];
4218     sv_catpvn(sv, hunk, 1);
4219     hunk[4] = '\0';
4220     while (len > 2) {
4221         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4222         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4223         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4224         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4225         sv_catpvn(sv, hunk, 4);
4226         s += 3;
4227         len -= 3;
4228     }
4229     if (len > 0) {
4230         char r = (len > 1 ? s[1] : '\0');
4231         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4232         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4233         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4234         hunk[3] = PL_uuemap[0];
4235         sv_catpvn(sv, hunk, 4);
4236     }
4237     sv_catpvn(sv, "\n", 1);
4238 }
4239
4240 STATIC SV *
4241 S_is_an_int(pTHX_ char *s, STRLEN l)
4242 {
4243   STRLEN         n_a;
4244   SV             *result = newSVpvn(s, l);
4245   char           *result_c = SvPV(result, n_a); /* convenience */
4246   char           *out = result_c;
4247   bool            skip = 1;
4248   bool            ignore = 0;
4249
4250   while (*s) {
4251     switch (*s) {
4252     case ' ':
4253       break;
4254     case '+':
4255       if (!skip) {
4256         SvREFCNT_dec(result);
4257         return (NULL);
4258       }
4259       break;
4260     case '0':
4261     case '1':
4262     case '2':
4263     case '3':
4264     case '4':
4265     case '5':
4266     case '6':
4267     case '7':
4268     case '8':
4269     case '9':
4270       skip = 0;
4271       if (!ignore) {
4272         *(out++) = *s;
4273       }
4274       break;
4275     case '.':
4276       ignore = 1;
4277       break;
4278     default:
4279       SvREFCNT_dec(result);
4280       return (NULL);
4281     }
4282     s++;
4283   }
4284   *(out++) = '\0';
4285   SvCUR_set(result, out - result_c);
4286   return (result);
4287 }
4288
4289 /* pnum must be '\0' terminated */
4290 STATIC int
4291 S_div128(pTHX_ SV *pnum, bool *done)
4292 {
4293   STRLEN          len;
4294   char           *s = SvPV(pnum, len);
4295   int             m = 0;
4296   int             r = 0;
4297   char           *t = s;
4298
4299   *done = 1;
4300   while (*t) {
4301     int             i;
4302
4303     i = m * 10 + (*t - '0');
4304     m = i & 0x7F;
4305     r = (i >> 7);               /* r < 10 */
4306     if (r) {
4307       *done = 0;
4308     }
4309     *(t++) = '0' + r;
4310   }
4311   *(t++) = '\0';
4312   SvCUR_set(pnum, (STRLEN) (t - s));
4313   return (m);
4314 }
4315
4316
4317 PP(pp_pack)
4318 {
4319     djSP; dMARK; dORIGMARK; dTARGET;
4320     register SV *cat = TARG;
4321     register I32 items;
4322     STRLEN fromlen;
4323     register char *pat = SvPVx(*++MARK, fromlen);
4324     register char *patend = pat + fromlen;
4325     register I32 len;
4326     I32 datumtype;
4327     SV *fromstr;
4328     /*SUPPRESS 442*/
4329     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4330     static char *space10 = "          ";
4331
4332     /* These must not be in registers: */
4333     char achar;
4334     I16 ashort;
4335     int aint;
4336     unsigned int auint;
4337     I32 along;
4338     U32 aulong;
4339 #ifdef HAS_QUAD
4340     Quad_t aquad;
4341     Uquad_t auquad;
4342 #endif
4343     char *aptr;
4344     float afloat;
4345     double adouble;
4346     int commas = 0;
4347 #ifdef PERL_NATINT_PACK
4348     int natint;         /* native integer */
4349 #endif
4350
4351     items = SP - MARK;
4352     MARK++;
4353     sv_setpvn(cat, "", 0);
4354     while (pat < patend) {
4355         SV *lengthcode = Nullsv;
4356 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4357         datumtype = *pat++ & 0xFF;
4358 #ifdef PERL_NATINT_PACK
4359         natint = 0;
4360 #endif
4361         if (isSPACE(datumtype))
4362             continue;
4363         if (datumtype == '#') {
4364             while (pat < patend && *pat != '\n')
4365                 pat++;
4366             continue;
4367         }
4368         if (*pat == '!') {
4369             char *natstr = "sSiIlL";
4370
4371             if (strchr(natstr, datumtype)) {
4372 #ifdef PERL_NATINT_PACK
4373                 natint = 1;
4374 #endif
4375                 pat++;
4376             }
4377             else
4378                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4379         }
4380         if (*pat == '*') {
4381             len = strchr("@Xxu", datumtype) ? 0 : items;
4382             pat++;
4383         }
4384         else if (isDIGIT(*pat)) {
4385             len = *pat++ - '0';
4386             while (isDIGIT(*pat)) {
4387                 len = (len * 10) + (*pat++ - '0');
4388                 if (len < 0)
4389                     DIE(aTHX_ "Repeat count in pack overflows");
4390             }
4391         }
4392         else
4393             len = 1;
4394         if (*pat == '/') {
4395             ++pat;
4396             if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4397                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4398             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4399                                                    ? *MARK : &PL_sv_no)));
4400         }
4401         switch(datumtype) {
4402         default:
4403             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4404         case ',': /* grandfather in commas but with a warning */
4405             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4406                 Perl_warner(aTHX_ WARN_UNSAFE,
4407                             "Invalid type in pack: '%c'", (int)datumtype);
4408             break;
4409         case '%':
4410             DIE(aTHX_ "%% may only be used in unpack");
4411         case '@':
4412             len -= SvCUR(cat);
4413             if (len > 0)
4414                 goto grow;
4415             len = -len;
4416             if (len > 0)
4417                 goto shrink;
4418             break;
4419         case 'X':
4420           shrink:
4421             if (SvCUR(cat) < len)
4422                 DIE(aTHX_ "X outside of string");
4423             SvCUR(cat) -= len;
4424             *SvEND(cat) = '\0';
4425             break;
4426         case 'x':
4427           grow:
4428             while (len >= 10) {
4429                 sv_catpvn(cat, null10, 10);
4430                 len -= 10;
4431             }
4432             sv_catpvn(cat, null10, len);
4433             break;
4434         case 'A':
4435         case 'Z':
4436         case 'a':
4437             fromstr = NEXTFROM;
4438             aptr = SvPV(fromstr, fromlen);
4439             if (pat[-1] == '*') {
4440                 len = fromlen;
4441                 if (datumtype == 'Z')
4442                     ++len;
4443             }
4444             if (fromlen >= len) {
4445                 sv_catpvn(cat, aptr, len);
4446                 if (datumtype == 'Z')
4447                     *(SvEND(cat)-1) = '\0';
4448             }
4449             else {
4450                 sv_catpvn(cat, aptr, fromlen);
4451                 len -= fromlen;
4452                 if (datumtype == 'A') {
4453                     while (len >= 10) {
4454                         sv_catpvn(cat, space10, 10);
4455                         len -= 10;
4456                     }
4457                     sv_catpvn(cat, space10, len);
4458                 }
4459                 else {
4460                     while (len >= 10) {
4461                         sv_catpvn(cat, null10, 10);
4462                         len -= 10;
4463                     }
4464                     sv_catpvn(cat, null10, len);
4465                 }
4466             }
4467             break;
4468         case 'B':
4469         case 'b':
4470             {
4471                 char *savepat = pat;
4472                 I32 saveitems;
4473
4474                 fromstr = NEXTFROM;
4475                 saveitems = items;
4476                 aptr = SvPV(fromstr, fromlen);
4477                 if (pat[-1] == '*')
4478                     len = fromlen;
4479                 pat = aptr;
4480                 aint = SvCUR(cat);
4481                 SvCUR(cat) += (len+7)/8;
4482                 SvGROW(cat, SvCUR(cat) + 1);
4483                 aptr = SvPVX(cat) + aint;
4484                 if (len > fromlen)
4485                     len = fromlen;
4486                 aint = len;
4487                 items = 0;
4488                 if (datumtype == 'B') {
4489                     for (len = 0; len++ < aint;) {
4490                         items |= *pat++ & 1;
4491                         if (len & 7)
4492                             items <<= 1;
4493                         else {
4494                             *aptr++ = items & 0xff;
4495                             items = 0;
4496                         }
4497                     }
4498                 }
4499                 else {
4500                     for (len = 0; len++ < aint;) {
4501                         if (*pat++ & 1)
4502                             items |= 128;
4503                         if (len & 7)
4504                             items >>= 1;
4505                         else {
4506                             *aptr++ = items & 0xff;
4507                             items = 0;
4508                         }
4509                     }
4510                 }
4511                 if (aint & 7) {
4512                     if (datumtype == 'B')
4513                         items <<= 7 - (aint & 7);
4514                     else
4515                         items >>= 7 - (aint & 7);
4516                     *aptr++ = items & 0xff;
4517                 }
4518                 pat = SvPVX(cat) + SvCUR(cat);
4519                 while (aptr <= pat)
4520                     *aptr++ = '\0';
4521
4522                 pat = savepat;
4523                 items = saveitems;
4524             }
4525             break;
4526         case 'H':
4527         case 'h':
4528             {
4529                 char *savepat = pat;
4530                 I32 saveitems;
4531
4532                 fromstr = NEXTFROM;
4533                 saveitems = items;
4534                 aptr = SvPV(fromstr, fromlen);
4535                 if (pat[-1] == '*')
4536                     len = fromlen;
4537                 pat = aptr;
4538                 aint = SvCUR(cat);
4539                 SvCUR(cat) += (len+1)/2;
4540                 SvGROW(cat, SvCUR(cat) + 1);
4541                 aptr = SvPVX(cat) + aint;
4542                 if (len > fromlen)
4543                     len = fromlen;
4544                 aint = len;
4545                 items = 0;
4546                 if (datumtype == 'H') {
4547                     for (len = 0; len++ < aint;) {
4548                         if (isALPHA(*pat))
4549                             items |= ((*pat++ & 15) + 9) & 15;
4550                         else
4551                             items |= *pat++ & 15;
4552                         if (len & 1)
4553                             items <<= 4;
4554                         else {
4555                             *aptr++ = items & 0xff;
4556                             items = 0;
4557                         }
4558                     }
4559                 }
4560                 else {
4561                     for (len = 0; len++ < aint;) {
4562                         if (isALPHA(*pat))
4563                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4564                         else
4565                             items |= (*pat++ & 15) << 4;
4566                         if (len & 1)
4567                             items >>= 4;
4568                         else {
4569                             *aptr++ = items & 0xff;
4570                             items = 0;
4571                         }
4572                     }
4573                 }
4574                 if (aint & 1)
4575                     *aptr++ = items & 0xff;
4576                 pat = SvPVX(cat) + SvCUR(cat);
4577                 while (aptr <= pat)
4578                     *aptr++ = '\0';
4579
4580                 pat = savepat;
4581                 items = saveitems;
4582             }
4583             break;
4584         case 'C':
4585         case 'c':
4586             while (len-- > 0) {
4587                 fromstr = NEXTFROM;
4588                 aint = SvIV(fromstr);
4589                 achar = aint;
4590                 sv_catpvn(cat, &achar, sizeof(char));
4591             }
4592             break;
4593         case 'U':
4594             while (len-- > 0) {
4595                 fromstr = NEXTFROM;
4596                 auint = SvUV(fromstr);
4597                 SvGROW(cat, SvCUR(cat) + 10);
4598                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4599                                - SvPVX(cat));
4600             }
4601             *SvEND(cat) = '\0';
4602             break;
4603         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4604         case 'f':
4605         case 'F':
4606             while (len-- > 0) {
4607                 fromstr = NEXTFROM;
4608                 afloat = (float)SvNV(fromstr);
4609                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4610             }
4611             break;
4612         case 'd':
4613         case 'D':
4614             while (len-- > 0) {
4615                 fromstr = NEXTFROM;
4616                 adouble = (double)SvNV(fromstr);
4617                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4618             }
4619             break;
4620         case 'n':
4621             while (len-- > 0) {
4622                 fromstr = NEXTFROM;
4623                 ashort = (I16)SvIV(fromstr);
4624 #ifdef HAS_HTONS
4625                 ashort = PerlSock_htons(ashort);
4626 #endif
4627                 CAT16(cat, &ashort);
4628             }
4629             break;
4630         case 'v':
4631             while (len-- > 0) {
4632                 fromstr = NEXTFROM;
4633                 ashort = (I16)SvIV(fromstr);
4634 #ifdef HAS_HTOVS
4635                 ashort = htovs(ashort);
4636 #endif
4637                 CAT16(cat, &ashort);
4638             }
4639             break;
4640         case 'S':
4641 #if SHORTSIZE != SIZE16
4642             if (natint) {
4643                 unsigned short aushort;
4644
4645                 while (len-- > 0) {
4646                     fromstr = NEXTFROM;
4647                     aushort = SvUV(fromstr);
4648                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4649                 }
4650             }
4651             else
4652 #endif
4653             {
4654                 U16 aushort;
4655
4656                 while (len-- > 0) {
4657                     fromstr = NEXTFROM;
4658                     aushort = (U16)SvUV(fromstr);
4659                     CAT16(cat, &aushort);
4660                 }
4661
4662             }
4663             break;
4664         case 's':
4665 #if SHORTSIZE != SIZE16
4666             if (natint) {
4667                 short ashort;
4668
4669                 while (len-- > 0) {
4670                     fromstr = NEXTFROM;
4671                     ashort = SvIV(fromstr);
4672                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4673                 }
4674             }
4675             else
4676 #endif
4677             {
4678                 while (len-- > 0) {
4679                     fromstr = NEXTFROM;
4680                     ashort = (I16)SvIV(fromstr);
4681                     CAT16(cat, &ashort);
4682                 }
4683             }
4684             break;
4685         case 'I':
4686             while (len-- > 0) {
4687                 fromstr = NEXTFROM;
4688                 auint = SvUV(fromstr);
4689                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4690             }
4691             break;
4692         case 'w':
4693             while (len-- > 0) {
4694                 fromstr = NEXTFROM;
4695                 adouble = Perl_floor(SvNV(fromstr));
4696
4697                 if (adouble < 0)
4698                     DIE(aTHX_ "Cannot compress negative numbers");
4699
4700                 if (
4701 #ifdef BW_BITS
4702                     adouble <= BW_MASK
4703 #else
4704 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4705                     adouble <= UV_MAX_cxux
4706 #else
4707                     adouble <= UV_MAX
4708 #endif
4709 #endif
4710                     )
4711                 {
4712                     char   buf[1 + sizeof(UV)];
4713                     char  *in = buf + sizeof(buf);
4714                     UV     auv = U_V(adouble);
4715
4716                     do {
4717                         *--in = (auv & 0x7f) | 0x80;
4718                         auv >>= 7;
4719                     } while (auv);
4720                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4721                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4722                 }
4723                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4724                     char           *from, *result, *in;
4725                     SV             *norm;
4726                     STRLEN          len;
4727                     bool            done;
4728
4729                     /* Copy string and check for compliance */
4730                     from = SvPV(fromstr, len);
4731                     if ((norm = is_an_int(from, len)) == NULL)
4732                         DIE(aTHX_ "can compress only unsigned integer");
4733
4734                     New('w', result, len, char);
4735                     in = result + len;
4736                     done = FALSE;
4737                     while (!done)
4738                         *--in = div128(norm, &done) | 0x80;
4739                     result[len - 1] &= 0x7F; /* clear continue bit */
4740                     sv_catpvn(cat, in, (result + len) - in);
4741                     Safefree(result);
4742                     SvREFCNT_dec(norm); /* free norm */
4743                 }
4744                 else if (SvNOKp(fromstr)) {
4745                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4746                     char  *in = buf + sizeof(buf);
4747
4748                     do {
4749                         double next = floor(adouble / 128);
4750                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4751                         if (--in < buf)  /* this cannot happen ;-) */
4752                             DIE(aTHX_ "Cannot compress integer");
4753                         adouble = next;
4754                     } while (adouble > 0);
4755                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4756                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4757                 }
4758                 else
4759                     DIE(aTHX_ "Cannot compress non integer");
4760             }
4761             break;
4762         case 'i':
4763             while (len-- > 0) {
4764                 fromstr = NEXTFROM;
4765                 aint = SvIV(fromstr);
4766                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4767             }
4768             break;
4769         case 'N':
4770             while (len-- > 0) {
4771                 fromstr = NEXTFROM;
4772                 aulong = SvUV(fromstr);
4773 #ifdef HAS_HTONL
4774                 aulong = PerlSock_htonl(aulong);
4775 #endif
4776                 CAT32(cat, &aulong);
4777             }
4778             break;
4779         case 'V':
4780             while (len-- > 0) {
4781                 fromstr = NEXTFROM;
4782                 aulong = SvUV(fromstr);
4783 #ifdef HAS_HTOVL
4784                 aulong = htovl(aulong);
4785 #endif
4786                 CAT32(cat, &aulong);
4787             }
4788             break;
4789         case 'L':
4790 #if LONGSIZE != SIZE32
4791             if (natint) {
4792                 unsigned long aulong;
4793
4794                 while (len-- > 0) {
4795                     fromstr = NEXTFROM;
4796                     aulong = SvUV(fromstr);
4797                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4798                 }
4799             }
4800             else
4801 #endif
4802             {
4803                 while (len-- > 0) {
4804                     fromstr = NEXTFROM;
4805                     aulong = SvUV(fromstr);
4806                     CAT32(cat, &aulong);
4807                 }
4808             }
4809             break;
4810         case 'l':
4811 #if LONGSIZE != SIZE32
4812             if (natint) {
4813                 long along;
4814
4815                 while (len-- > 0) {
4816                     fromstr = NEXTFROM;
4817                     along = SvIV(fromstr);
4818                     sv_catpvn(cat, (char *)&along, sizeof(long));
4819                 }
4820             }
4821             else
4822 #endif
4823             {
4824                 while (len-- > 0) {
4825                     fromstr = NEXTFROM;
4826                     along = SvIV(fromstr);
4827                     CAT32(cat, &along);
4828                 }
4829             }
4830             break;
4831 #ifdef HAS_QUAD
4832         case 'Q':
4833             while (len-- > 0) {
4834                 fromstr = NEXTFROM;
4835                 auquad = (Uquad_t)SvUV(fromstr);
4836                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4837             }
4838             break;
4839         case 'q':
4840             while (len-- > 0) {
4841                 fromstr = NEXTFROM;
4842                 aquad = (Quad_t)SvIV(fromstr);
4843                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4844             }
4845             break;
4846 #endif
4847         case 'P':
4848             len = 1;            /* assume SV is correct length */
4849             /* FALL THROUGH */
4850         case 'p':
4851             while (len-- > 0) {
4852                 fromstr = NEXTFROM;
4853                 if (fromstr == &PL_sv_undef)
4854                     aptr = NULL;
4855                 else {
4856                     STRLEN n_a;
4857                     /* XXX better yet, could spirit away the string to
4858                      * a safe spot and hang on to it until the result
4859                      * of pack() (and all copies of the result) are
4860                      * gone.
4861                      */
4862                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4863                         Perl_warner(aTHX_ WARN_UNSAFE,
4864                                 "Attempt to pack pointer to temporary value");
4865                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4866                         aptr = SvPV(fromstr,n_a);
4867                     else
4868                         aptr = SvPV_force(fromstr,n_a);
4869                 }
4870                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4871             }
4872             break;
4873         case 'u':
4874             fromstr = NEXTFROM;
4875             aptr = SvPV(fromstr, fromlen);
4876             SvGROW(cat, fromlen * 4 / 3);
4877             if (len <= 1)
4878                 len = 45;
4879             else
4880                 len = len / 3 * 3;
4881             while (fromlen > 0) {
4882                 I32 todo;
4883
4884                 if (fromlen > len)
4885                     todo = len;
4886                 else
4887                     todo = fromlen;
4888                 doencodes(cat, aptr, todo);
4889                 fromlen -= todo;
4890                 aptr += todo;
4891             }
4892             break;
4893         }
4894     }
4895     SvSETMAGIC(cat);
4896     SP = ORIGMARK;
4897     PUSHs(cat);
4898     RETURN;
4899 }
4900 #undef NEXTFROM
4901
4902
4903 PP(pp_split)
4904 {
4905     djSP; dTARG;
4906     AV *ary;
4907     register I32 limit = POPi;                  /* note, negative is forever */
4908     SV *sv = POPs;
4909     STRLEN len;
4910     register char *s = SvPV(sv, len);
4911     char *strend = s + len;
4912     register PMOP *pm;
4913     register REGEXP *rx;
4914     register SV *dstr;
4915     register char *m;
4916     I32 iters = 0;
4917     I32 maxiters = (strend - s) + 10;
4918     I32 i;
4919     char *orig;
4920     I32 origlimit = limit;
4921     I32 realarray = 0;
4922     I32 base;
4923     AV *oldstack = PL_curstack;
4924     I32 gimme = GIMME_V;
4925     I32 oldsave = PL_savestack_ix;
4926     I32 make_mortal = 1;
4927     MAGIC *mg = (MAGIC *) NULL;
4928
4929 #ifdef DEBUGGING
4930     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4931 #else
4932     pm = (PMOP*)POPs;
4933 #endif
4934     if (!pm || !s)
4935         DIE(aTHX_ "panic: do_split");
4936     rx = pm->op_pmregexp;
4937
4938     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4939              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4940
4941     if (pm->op_pmreplroot) {
4942 #ifdef USE_ITHREADS
4943         ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4944 #else
4945         ary = GvAVn((GV*)pm->op_pmreplroot);
4946 #endif
4947     }
4948     else if (gimme != G_ARRAY)
4949 #ifdef USE_THREADS
4950         ary = (AV*)PL_curpad[0];
4951 #else
4952         ary = GvAVn(PL_defgv);
4953 #endif /* USE_THREADS */
4954     else
4955         ary = Nullav;
4956     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4957         realarray = 1;
4958         PUTBACK;
4959         av_extend(ary,0);
4960         av_clear(ary);
4961         SPAGAIN;
4962         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4963             PUSHMARK(SP);
4964             XPUSHs(SvTIED_obj((SV*)ary, mg));
4965         }
4966         else {
4967             if (!AvREAL(ary)) {
4968                 AvREAL_on(ary);
4969                 AvREIFY_off(ary);
4970                 for (i = AvFILLp(ary); i >= 0; i--)
4971                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4972             }
4973             /* temporarily switch stacks */
4974             SWITCHSTACK(PL_curstack, ary);
4975             make_mortal = 0;
4976         }
4977     }
4978     base = SP - PL_stack_base;
4979     orig = s;
4980     if (pm->op_pmflags & PMf_SKIPWHITE) {
4981         if (pm->op_pmflags & PMf_LOCALE) {
4982             while (isSPACE_LC(*s))
4983                 s++;
4984         }
4985         else {
4986             while (isSPACE(*s))
4987                 s++;
4988         }
4989     }
4990     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4991         SAVEINT(PL_multiline);
4992         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4993     }
4994
4995     if (!limit)
4996         limit = maxiters + 2;
4997     if (pm->op_pmflags & PMf_WHITE) {
4998         while (--limit) {
4999             m = s;
5000             while (m < strend &&
5001                    !((pm->op_pmflags & PMf_LOCALE)
5002                      ? isSPACE_LC(*m) : isSPACE(*m)))
5003                 ++m;
5004             if (m >= strend)
5005                 break;
5006
5007             dstr = NEWSV(30, m-s);
5008             sv_setpvn(dstr, s, m-s);
5009             if (make_mortal)
5010                 sv_2mortal(dstr);
5011             XPUSHs(dstr);
5012
5013             s = m + 1;
5014             while (s < strend &&
5015                    ((pm->op_pmflags & PMf_LOCALE)
5016                     ? isSPACE_LC(*s) : isSPACE(*s)))
5017                 ++s;
5018         }
5019     }
5020     else if (strEQ("^", rx->precomp)) {
5021         while (--limit) {
5022             /*SUPPRESS 530*/
5023             for (m = s; m < strend && *m != '\n'; m++) ;
5024             m++;
5025             if (m >= strend)
5026                 break;
5027             dstr = NEWSV(30, m-s);
5028             sv_setpvn(dstr, s, m-s);
5029             if (make_mortal)
5030                 sv_2mortal(dstr);
5031             XPUSHs(dstr);
5032             s = m;
5033         }
5034     }
5035     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5036              && (rx->reganch & ROPT_CHECK_ALL)
5037              && !(rx->reganch & ROPT_ANCH)) {
5038         int tail = (rx->reganch & RE_INTUIT_TAIL);
5039         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5040         char c;
5041
5042         len = rx->minlen;
5043         if (len == 1 && !tail) {
5044             c = *SvPV(csv,len);
5045             while (--limit) {
5046                 /*SUPPRESS 530*/
5047                 for (m = s; m < strend && *m != c; m++) ;
5048                 if (m >= strend)
5049                     break;
5050                 dstr = NEWSV(30, m-s);
5051                 sv_setpvn(dstr, s, m-s);
5052                 if (make_mortal)
5053                     sv_2mortal(dstr);
5054                 XPUSHs(dstr);
5055                 s = m + 1;
5056             }
5057         }
5058         else {
5059 #ifndef lint
5060             while (s < strend && --limit &&
5061               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5062                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5063 #endif
5064             {
5065                 dstr = NEWSV(31, m-s);
5066                 sv_setpvn(dstr, s, m-s);
5067                 if (make_mortal)
5068                     sv_2mortal(dstr);
5069                 XPUSHs(dstr);
5070                 s = m + len;            /* Fake \n at the end */
5071             }
5072         }
5073     }
5074     else {
5075         maxiters += (strend - s) * rx->nparens;
5076         while (s < strend && --limit
5077 /*             && (!rx->check_substr
5078                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5079                                                  0, NULL))))
5080 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5081                               1 /* minend */, sv, NULL, 0))
5082         {
5083             TAINT_IF(RX_MATCH_TAINTED(rx));
5084             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5085                 m = s;
5086                 s = orig;
5087                 orig = rx->subbeg;
5088                 s = orig + (m - s);
5089                 strend = s + (strend - m);
5090             }
5091             m = rx->startp[0] + orig;
5092             dstr = NEWSV(32, m-s);
5093             sv_setpvn(dstr, s, m-s);
5094             if (make_mortal)
5095                 sv_2mortal(dstr);
5096             XPUSHs(dstr);
5097             if (rx->nparens) {
5098                 for (i = 1; i <= rx->nparens; i++) {
5099                     s = rx->startp[i] + orig;
5100                     m = rx->endp[i] + orig;
5101                     if (m && s) {
5102                         dstr = NEWSV(33, m-s);
5103                         sv_setpvn(dstr, s, m-s);
5104                     }
5105                     else
5106                         dstr = NEWSV(33, 0);
5107                     if (make_mortal)
5108                         sv_2mortal(dstr);
5109                     XPUSHs(dstr);
5110                 }
5111             }
5112             s = rx->endp[0] + orig;
5113         }
5114     }
5115
5116     LEAVE_SCOPE(oldsave);
5117     iters = (SP - PL_stack_base) - base;
5118     if (iters > maxiters)
5119         DIE(aTHX_ "Split loop");
5120
5121     /* keep field after final delim? */
5122     if (s < strend || (iters && origlimit)) {
5123         dstr = NEWSV(34, strend-s);
5124         sv_setpvn(dstr, s, strend-s);
5125         if (make_mortal)
5126             sv_2mortal(dstr);
5127         XPUSHs(dstr);
5128         iters++;
5129     }
5130     else if (!origlimit) {
5131         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5132             iters--, SP--;
5133     }
5134
5135     if (realarray) {
5136         if (!mg) {
5137             SWITCHSTACK(ary, oldstack);
5138             if (SvSMAGICAL(ary)) {
5139                 PUTBACK;
5140                 mg_set((SV*)ary);
5141                 SPAGAIN;
5142             }
5143             if (gimme == G_ARRAY) {
5144                 EXTEND(SP, iters);
5145                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5146                 SP += iters;
5147                 RETURN;
5148             }
5149         }
5150         else {
5151             PUTBACK;
5152             ENTER;
5153             call_method("PUSH",G_SCALAR|G_DISCARD);
5154             LEAVE;
5155             SPAGAIN;
5156             if (gimme == G_ARRAY) {
5157                 /* EXTEND should not be needed - we just popped them */
5158                 EXTEND(SP, iters);
5159                 for (i=0; i < iters; i++) {
5160                     SV **svp = av_fetch(ary, i, FALSE);
5161                     PUSHs((svp) ? *svp : &PL_sv_undef);
5162                 }
5163                 RETURN;
5164             }
5165         }
5166     }
5167     else {
5168         if (gimme == G_ARRAY)
5169             RETURN;
5170     }
5171     if (iters || !pm->op_pmreplroot) {
5172         GETTARGET;
5173         PUSHi(iters);
5174         RETURN;
5175     }
5176     RETPUSHUNDEF;
5177 }
5178
5179 #ifdef USE_THREADS
5180 void
5181 Perl_unlock_condpair(pTHX_ void *svv)
5182 {
5183     dTHR;
5184     MAGIC *mg = mg_find((SV*)svv, 'm');
5185
5186     if (!mg)
5187         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5188     MUTEX_LOCK(MgMUTEXP(mg));
5189     if (MgOWNER(mg) != thr)
5190         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5191     MgOWNER(mg) = 0;
5192     COND_SIGNAL(MgOWNERCONDP(mg));
5193     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5194                           PTR2UV(thr), PTR2UV(svv));)
5195     MUTEX_UNLOCK(MgMUTEXP(mg));
5196 }
5197 #endif /* USE_THREADS */
5198
5199 PP(pp_lock)
5200 {
5201     djSP;
5202     dTOPss;
5203     SV *retsv = sv;
5204 #ifdef USE_THREADS
5205     MAGIC *mg;
5206
5207     if (SvROK(sv))
5208         sv = SvRV(sv);
5209
5210     mg = condpair_magic(sv);
5211     MUTEX_LOCK(MgMUTEXP(mg));
5212     if (MgOWNER(mg) == thr)
5213         MUTEX_UNLOCK(MgMUTEXP(mg));
5214     else {
5215         while (MgOWNER(mg))
5216             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5217         MgOWNER(mg) = thr;
5218         DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5219                               PTR2UV(thr), PTR2UV(sv));)
5220         MUTEX_UNLOCK(MgMUTEXP(mg));
5221         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5222     }
5223 #endif /* USE_THREADS */
5224     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5225         || SvTYPE(retsv) == SVt_PVCV) {
5226         retsv = refto(retsv);
5227     }
5228     SETs(retsv);
5229     RETURN;
5230 }
5231
5232 PP(pp_threadsv)
5233 {
5234     djSP;
5235 #ifdef USE_THREADS
5236     EXTEND(SP, 1);
5237     if (PL_op->op_private & OPpLVAL_INTRO)
5238         PUSHs(*save_threadsv(PL_op->op_targ));
5239     else
5240         PUSHs(THREADSV(PL_op->op_targ));
5241     RETURN;
5242 #else
5243     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5244 #endif /* USE_THREADS */
5245 }