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