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             DIE(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                 DIE(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         DIE(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         DIE(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         DIE(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                 DIE(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                     DIE(aTHX_ "Repeat count in unpack overflows");
3320             }
3321         }
3322         else
3323             len = (datumtype != '@');
3324         switch(datumtype) {
3325         default:
3326             DIE(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,
3330                             "Invalid type in unpack: '%c'", (int)datumtype);
3331             break;
3332         case '%':
3333             if (len == 1 && pat[-1] != '1')
3334                 len = 16;
3335             checksum = len;
3336             culong = 0;
3337             cdouble = 0;
3338             if (pat < patend)
3339                 goto reparse;
3340             break;
3341         case '@':
3342             if (len > strend - strbeg)
3343                 DIE(aTHX_ "@ outside of string");
3344             s = strbeg + len;
3345             break;
3346         case 'X':
3347             if (len > s - strbeg)
3348                 DIE(aTHX_ "X outside of string");
3349             s -= len;
3350             break;
3351         case 'x':
3352             if (len > strend - s)
3353                 DIE(aTHX_ "x outside of string");
3354             s += len;
3355             break;
3356         case '/':
3357             if (oldsp >= SP)
3358                 DIE(aTHX_ "/ must follow a numeric type");
3359             if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3360                 DIE(aTHX_ "/ must be followed by a, A or Z");
3361             datumtype = *pat++;
3362             if (*pat == '*')
3363                 pat++;          /* ignore '*' for compatibility with pack */
3364             if (isDIGIT(*pat))
3365                 DIE(aTHX_ "/ cannot take a count" );
3366             len = POPi;
3367             /* drop through */
3368         case 'A':
3369         case 'Z':
3370         case 'a':
3371             if (len > strend - s)
3372                 len = strend - s;
3373             if (checksum)
3374                 goto uchar_checksum;
3375             sv = NEWSV(35, len);
3376             sv_setpvn(sv, s, len);
3377             s += len;
3378             if (datumtype == 'A' || datumtype == 'Z') {
3379                 aptr = s;       /* borrow register */
3380                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3381                     s = SvPVX(sv);
3382                     while (*s)
3383                         s++;
3384                 }
3385                 else {          /* 'A' strips both nulls and spaces */
3386                     s = SvPVX(sv) + len - 1;
3387                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3388                         s--;
3389                     *++s = '\0';
3390                 }
3391                 SvCUR_set(sv, s - SvPVX(sv));
3392                 s = aptr;       /* unborrow register */
3393             }
3394             XPUSHs(sv_2mortal(sv));
3395             break;
3396         case 'B':
3397         case 'b':
3398             if (pat[-1] == '*' || len > (strend - s) * 8)
3399                 len = (strend - s) * 8;
3400             if (checksum) {
3401                 if (!PL_bitcount) {
3402                     Newz(601, PL_bitcount, 256, char);
3403                     for (bits = 1; bits < 256; bits++) {
3404                         if (bits & 1)   PL_bitcount[bits]++;
3405                         if (bits & 2)   PL_bitcount[bits]++;
3406                         if (bits & 4)   PL_bitcount[bits]++;
3407                         if (bits & 8)   PL_bitcount[bits]++;
3408                         if (bits & 16)  PL_bitcount[bits]++;
3409                         if (bits & 32)  PL_bitcount[bits]++;
3410                         if (bits & 64)  PL_bitcount[bits]++;
3411                         if (bits & 128) PL_bitcount[bits]++;
3412                     }
3413                 }
3414                 while (len >= 8) {
3415                     culong += PL_bitcount[*(unsigned char*)s++];
3416                     len -= 8;
3417                 }
3418                 if (len) {
3419                     bits = *s;
3420                     if (datumtype == 'b') {
3421                         while (len-- > 0) {
3422                             if (bits & 1) culong++;
3423                             bits >>= 1;
3424                         }
3425                     }
3426                     else {
3427                         while (len-- > 0) {
3428                             if (bits & 128) culong++;
3429                             bits <<= 1;
3430                         }
3431                     }
3432                 }
3433                 break;
3434             }
3435             sv = NEWSV(35, len + 1);
3436             SvCUR_set(sv, len);
3437             SvPOK_on(sv);
3438             aptr = pat;                 /* borrow register */
3439             pat = SvPVX(sv);
3440             if (datumtype == 'b') {
3441                 aint = len;
3442                 for (len = 0; len < aint; len++) {
3443                     if (len & 7)                /*SUPPRESS 595*/
3444                         bits >>= 1;
3445                     else
3446                         bits = *s++;
3447                     *pat++ = '0' + (bits & 1);
3448                 }
3449             }
3450             else {
3451                 aint = len;
3452                 for (len = 0; len < aint; len++) {
3453                     if (len & 7)
3454                         bits <<= 1;
3455                     else
3456                         bits = *s++;
3457                     *pat++ = '0' + ((bits & 128) != 0);
3458                 }
3459             }
3460             *pat = '\0';
3461             pat = aptr;                 /* unborrow register */
3462             XPUSHs(sv_2mortal(sv));
3463             break;
3464         case 'H':
3465         case 'h':
3466             if (pat[-1] == '*' || len > (strend - s) * 2)
3467                 len = (strend - s) * 2;
3468             sv = NEWSV(35, len + 1);
3469             SvCUR_set(sv, len);
3470             SvPOK_on(sv);
3471             aptr = pat;                 /* borrow register */
3472             pat = SvPVX(sv);
3473             if (datumtype == 'h') {
3474                 aint = len;
3475                 for (len = 0; len < aint; len++) {
3476                     if (len & 1)
3477                         bits >>= 4;
3478                     else
3479                         bits = *s++;
3480                     *pat++ = PL_hexdigit[bits & 15];
3481                 }
3482             }
3483             else {
3484                 aint = len;
3485                 for (len = 0; len < aint; len++) {
3486                     if (len & 1)
3487                         bits <<= 4;
3488                     else
3489                         bits = *s++;
3490                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3491                 }
3492             }
3493             *pat = '\0';
3494             pat = aptr;                 /* unborrow register */
3495             XPUSHs(sv_2mortal(sv));
3496             break;
3497         case 'c':
3498             if (len > strend - s)
3499                 len = strend - s;
3500             if (checksum) {
3501                 while (len-- > 0) {
3502                     aint = *s++;
3503                     if (aint >= 128)    /* fake up signed chars */
3504                         aint -= 256;
3505                     culong += aint;
3506                 }
3507             }
3508             else {
3509                 EXTEND(SP, len);
3510                 EXTEND_MORTAL(len);
3511                 while (len-- > 0) {
3512                     aint = *s++;
3513                     if (aint >= 128)    /* fake up signed chars */
3514                         aint -= 256;
3515                     sv = NEWSV(36, 0);
3516                     sv_setiv(sv, (IV)aint);
3517                     PUSHs(sv_2mortal(sv));
3518                 }
3519             }
3520             break;
3521         case 'C':
3522             if (len > strend - s)
3523                 len = strend - s;
3524             if (checksum) {
3525               uchar_checksum:
3526                 while (len-- > 0) {
3527                     auint = *s++ & 255;
3528                     culong += auint;
3529                 }
3530             }
3531             else {
3532                 EXTEND(SP, len);
3533                 EXTEND_MORTAL(len);
3534                 while (len-- > 0) {
3535                     auint = *s++ & 255;
3536                     sv = NEWSV(37, 0);
3537                     sv_setiv(sv, (IV)auint);
3538                     PUSHs(sv_2mortal(sv));
3539                 }
3540             }
3541             break;
3542         case 'U':
3543             if (len > strend - s)
3544                 len = strend - s;
3545             if (checksum) {
3546                 while (len-- > 0 && s < strend) {
3547                     auint = utf8_to_uv((U8*)s, &along);
3548                     s += along;
3549                     if (checksum > 32)
3550                         cdouble += (NV)auint;
3551                     else
3552                         culong += auint;
3553                 }
3554             }
3555             else {
3556                 EXTEND(SP, len);
3557                 EXTEND_MORTAL(len);
3558                 while (len-- > 0 && s < strend) {
3559                     auint = utf8_to_uv((U8*)s, &along);
3560                     s += along;
3561                     sv = NEWSV(37, 0);
3562                     sv_setuv(sv, (UV)auint);
3563                     PUSHs(sv_2mortal(sv));
3564                 }
3565             }
3566             break;
3567         case 's':
3568 #if SHORTSIZE == SIZE16
3569             along = (strend - s) / SIZE16;
3570 #else
3571             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3572 #endif
3573             if (len > along)
3574                 len = along;
3575             if (checksum) {
3576 #if SHORTSIZE != SIZE16
3577                 if (natint) {
3578                     short ashort;
3579                     while (len-- > 0) {
3580                         COPYNN(s, &ashort, sizeof(short));
3581                         s += sizeof(short);
3582                         culong += ashort;
3583
3584                     }
3585                 }
3586                 else
3587 #endif
3588                 {
3589                     while (len-- > 0) {
3590                         COPY16(s, &ashort);
3591 #if SHORTSIZE > SIZE16
3592                         if (ashort > 32767)
3593                           ashort -= 65536;
3594 #endif
3595                         s += SIZE16;
3596                         culong += ashort;
3597                     }
3598                 }
3599             }
3600             else {
3601                 EXTEND(SP, len);
3602                 EXTEND_MORTAL(len);
3603 #if SHORTSIZE != SIZE16
3604                 if (natint) {
3605                     short ashort;
3606                     while (len-- > 0) {
3607                         COPYNN(s, &ashort, sizeof(short));
3608                         s += sizeof(short);
3609                         sv = NEWSV(38, 0);
3610                         sv_setiv(sv, (IV)ashort);
3611                         PUSHs(sv_2mortal(sv));
3612                     }
3613                 }
3614                 else
3615 #endif
3616                 {
3617                     while (len-- > 0) {
3618                         COPY16(s, &ashort);
3619 #if SHORTSIZE > SIZE16
3620                         if (ashort > 32767)
3621                           ashort -= 65536;
3622 #endif
3623                         s += SIZE16;
3624                         sv = NEWSV(38, 0);
3625                         sv_setiv(sv, (IV)ashort);
3626                         PUSHs(sv_2mortal(sv));
3627                     }
3628                 }
3629             }
3630             break;
3631         case 'v':
3632         case 'n':
3633         case 'S':
3634 #if SHORTSIZE == SIZE16
3635             along = (strend - s) / SIZE16;
3636 #else
3637             unatint = natint && datumtype == 'S';
3638             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3639 #endif
3640             if (len > along)
3641                 len = along;
3642             if (checksum) {
3643 #if SHORTSIZE != SIZE16
3644                 if (unatint) {
3645                     unsigned short aushort;
3646                     while (len-- > 0) {
3647                         COPYNN(s, &aushort, sizeof(unsigned short));
3648                         s += sizeof(unsigned short);
3649                         culong += aushort;
3650                     }
3651                 }
3652                 else
3653 #endif
3654                 {
3655                     while (len-- > 0) {
3656                         COPY16(s, &aushort);
3657                         s += SIZE16;
3658 #ifdef HAS_NTOHS
3659                         if (datumtype == 'n')
3660                             aushort = PerlSock_ntohs(aushort);
3661 #endif
3662 #ifdef HAS_VTOHS
3663                         if (datumtype == 'v')
3664                             aushort = vtohs(aushort);
3665 #endif
3666                         culong += aushort;
3667                     }
3668                 }
3669             }
3670             else {
3671                 EXTEND(SP, len);
3672                 EXTEND_MORTAL(len);
3673 #if SHORTSIZE != SIZE16
3674                 if (unatint) {
3675                     unsigned short aushort;
3676                     while (len-- > 0) {
3677                         COPYNN(s, &aushort, sizeof(unsigned short));
3678                         s += sizeof(unsigned short);
3679                         sv = NEWSV(39, 0);
3680                         sv_setiv(sv, (UV)aushort);
3681                         PUSHs(sv_2mortal(sv));
3682                     }
3683                 }
3684                 else
3685 #endif
3686                 {
3687                     while (len-- > 0) {
3688                         COPY16(s, &aushort);
3689                         s += SIZE16;
3690                         sv = NEWSV(39, 0);
3691 #ifdef HAS_NTOHS
3692                         if (datumtype == 'n')
3693                             aushort = PerlSock_ntohs(aushort);
3694 #endif
3695 #ifdef HAS_VTOHS
3696                         if (datumtype == 'v')
3697                             aushort = vtohs(aushort);
3698 #endif
3699                         sv_setiv(sv, (UV)aushort);
3700                         PUSHs(sv_2mortal(sv));
3701                     }
3702                 }
3703             }
3704             break;
3705         case 'i':
3706             along = (strend - s) / sizeof(int);
3707             if (len > along)
3708                 len = along;
3709             if (checksum) {
3710                 while (len-- > 0) {
3711                     Copy(s, &aint, 1, int);
3712                     s += sizeof(int);
3713                     if (checksum > 32)
3714                         cdouble += (NV)aint;
3715                     else
3716                         culong += aint;
3717                 }
3718             }
3719             else {
3720                 EXTEND(SP, len);
3721                 EXTEND_MORTAL(len);
3722                 while (len-- > 0) {
3723                     Copy(s, &aint, 1, int);
3724                     s += sizeof(int);
3725                     sv = NEWSV(40, 0);
3726 #ifdef __osf__
3727                     /* Without the dummy below unpack("i", pack("i",-1))
3728                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3729                      * cc with optimization turned on.
3730                      *
3731                      * The bug was detected in
3732                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3733                      * with optimization (-O4) turned on.
3734                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3735                      * does not have this problem even with -O4.
3736                      *
3737                      * This bug was reported as DECC_BUGS 1431
3738                      * and tracked internally as GEM_BUGS 7775.
3739                      *
3740                      * The bug is fixed in
3741                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
3742                      * UNIX V4.0F support:   DEC C V5.9-006 or later
3743                      * UNIX V4.0E support:   DEC C V5.8-011 or later
3744                      * and also in DTK.
3745                      *
3746                      * See also few lines later for the same bug.
3747                      */
3748                     (aint) ?
3749                         sv_setiv(sv, (IV)aint) :
3750 #endif
3751                     sv_setiv(sv, (IV)aint);
3752                     PUSHs(sv_2mortal(sv));
3753                 }
3754             }
3755             break;
3756         case 'I':
3757             along = (strend - s) / sizeof(unsigned int);
3758             if (len > along)
3759                 len = along;
3760             if (checksum) {
3761                 while (len-- > 0) {
3762                     Copy(s, &auint, 1, unsigned int);
3763                     s += sizeof(unsigned int);
3764                     if (checksum > 32)
3765                         cdouble += (NV)auint;
3766                     else
3767                         culong += auint;
3768                 }
3769             }
3770             else {
3771                 EXTEND(SP, len);
3772                 EXTEND_MORTAL(len);
3773                 while (len-- > 0) {
3774                     Copy(s, &auint, 1, unsigned int);
3775                     s += sizeof(unsigned int);
3776                     sv = NEWSV(41, 0);
3777 #ifdef __osf__
3778                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3779                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3780                      * See details few lines earlier. */
3781                     (auint) ?
3782                         sv_setuv(sv, (UV)auint) :
3783 #endif
3784                     sv_setuv(sv, (UV)auint);
3785                     PUSHs(sv_2mortal(sv));
3786                 }
3787             }
3788             break;
3789         case 'l':
3790 #if LONGSIZE == SIZE32
3791             along = (strend - s) / SIZE32;
3792 #else
3793             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3794 #endif
3795             if (len > along)
3796                 len = along;
3797             if (checksum) {
3798 #if LONGSIZE != SIZE32
3799                 if (natint) {
3800                     long along;
3801                     while (len-- > 0) {
3802                         COPYNN(s, &along, sizeof(long));
3803                         s += sizeof(long);
3804                         if (checksum > 32)
3805                             cdouble += (NV)along;
3806                         else
3807                             culong += along;
3808                     }
3809                 }
3810                 else
3811 #endif
3812                 {
3813                     while (len-- > 0) {
3814                         COPY32(s, &along);
3815 #if LONGSIZE > SIZE32
3816                         if (along > 2147483647)
3817                           along -= 4294967296;
3818 #endif
3819                         s += SIZE32;
3820                         if (checksum > 32)
3821                             cdouble += (NV)along;
3822                         else
3823                             culong += along;
3824                     }
3825                 }
3826             }
3827             else {
3828                 EXTEND(SP, len);
3829                 EXTEND_MORTAL(len);
3830 #if LONGSIZE != SIZE32
3831                 if (natint) {
3832                     long along;
3833                     while (len-- > 0) {
3834                         COPYNN(s, &along, sizeof(long));
3835                         s += sizeof(long);
3836                         sv = NEWSV(42, 0);
3837                         sv_setiv(sv, (IV)along);
3838                         PUSHs(sv_2mortal(sv));
3839                     }
3840                 }
3841                 else
3842 #endif
3843                 {
3844                     while (len-- > 0) {
3845                         COPY32(s, &along);
3846 #if LONGSIZE > SIZE32
3847                         if (along > 2147483647)
3848                           along -= 4294967296;
3849 #endif
3850                         s += SIZE32;
3851                         sv = NEWSV(42, 0);
3852                         sv_setiv(sv, (IV)along);
3853                         PUSHs(sv_2mortal(sv));
3854                     }
3855                 }
3856             }
3857             break;
3858         case 'V':
3859         case 'N':
3860         case 'L':
3861 #if LONGSIZE == SIZE32
3862             along = (strend - s) / SIZE32;
3863 #else
3864             unatint = natint && datumtype == 'L';
3865             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3866 #endif
3867             if (len > along)
3868                 len = along;
3869             if (checksum) {
3870 #if LONGSIZE != SIZE32
3871                 if (unatint) {
3872                     unsigned long aulong;
3873                     while (len-- > 0) {
3874                         COPYNN(s, &aulong, sizeof(unsigned long));
3875                         s += sizeof(unsigned long);
3876                         if (checksum > 32)
3877                             cdouble += (NV)aulong;
3878                         else
3879                             culong += aulong;
3880                     }
3881                 }
3882                 else
3883 #endif
3884                 {
3885                     while (len-- > 0) {
3886                         COPY32(s, &aulong);
3887                         s += SIZE32;
3888 #ifdef HAS_NTOHL
3889                         if (datumtype == 'N')
3890                             aulong = PerlSock_ntohl(aulong);
3891 #endif
3892 #ifdef HAS_VTOHL
3893                         if (datumtype == 'V')
3894                             aulong = vtohl(aulong);
3895 #endif
3896                         if (checksum > 32)
3897                             cdouble += (NV)aulong;
3898                         else
3899                             culong += aulong;
3900                     }
3901                 }
3902             }
3903             else {
3904                 EXTEND(SP, len);
3905                 EXTEND_MORTAL(len);
3906 #if LONGSIZE != SIZE32
3907                 if (unatint) {
3908                     unsigned long aulong;
3909                     while (len-- > 0) {
3910                         COPYNN(s, &aulong, sizeof(unsigned long));
3911                         s += sizeof(unsigned long);
3912                         sv = NEWSV(43, 0);
3913                         sv_setuv(sv, (UV)aulong);
3914                         PUSHs(sv_2mortal(sv));
3915                     }
3916                 }
3917                 else
3918 #endif
3919                 {
3920                     while (len-- > 0) {
3921                         COPY32(s, &aulong);
3922                         s += SIZE32;
3923 #ifdef HAS_NTOHL
3924                         if (datumtype == 'N')
3925                             aulong = PerlSock_ntohl(aulong);
3926 #endif
3927 #ifdef HAS_VTOHL
3928                         if (datumtype == 'V')
3929                             aulong = vtohl(aulong);
3930 #endif
3931                         sv = NEWSV(43, 0);
3932                         sv_setuv(sv, (UV)aulong);
3933                         PUSHs(sv_2mortal(sv));
3934                     }
3935                 }
3936             }
3937             break;
3938         case 'p':
3939             along = (strend - s) / sizeof(char*);
3940             if (len > along)
3941                 len = along;
3942             EXTEND(SP, len);
3943             EXTEND_MORTAL(len);
3944             while (len-- > 0) {
3945                 if (sizeof(char*) > strend - s)
3946                     break;
3947                 else {
3948                     Copy(s, &aptr, 1, char*);
3949                     s += sizeof(char*);
3950                 }
3951                 sv = NEWSV(44, 0);
3952                 if (aptr)
3953                     sv_setpv(sv, aptr);
3954                 PUSHs(sv_2mortal(sv));
3955             }
3956             break;
3957         case 'w':
3958             EXTEND(SP, len);
3959             EXTEND_MORTAL(len);
3960             {
3961                 UV auv = 0;
3962                 U32 bytes = 0;
3963
3964                 while ((len > 0) && (s < strend)) {
3965                     auv = (auv << 7) | (*s & 0x7f);
3966                     if (!(*s++ & 0x80)) {
3967                         bytes = 0;
3968                         sv = NEWSV(40, 0);
3969                         sv_setuv(sv, auv);
3970                         PUSHs(sv_2mortal(sv));
3971                         len--;
3972                         auv = 0;
3973                     }
3974                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3975                         char *t;
3976                         STRLEN n_a;
3977
3978                         sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3979                         while (s < strend) {
3980                             sv = mul128(sv, *s & 0x7f);
3981                             if (!(*s++ & 0x80)) {
3982                                 bytes = 0;
3983                                 break;
3984                             }
3985                         }
3986                         t = SvPV(sv, n_a);
3987                         while (*t == '0')
3988                             t++;
3989                         sv_chop(sv, t);
3990                         PUSHs(sv_2mortal(sv));
3991                         len--;
3992                         auv = 0;
3993                     }
3994                 }
3995                 if ((s >= strend) && bytes)
3996                     DIE(aTHX_ "Unterminated compressed integer");
3997             }
3998             break;
3999         case 'P':
4000             EXTEND(SP, 1);
4001             if (sizeof(char*) > strend - s)
4002                 break;
4003             else {
4004                 Copy(s, &aptr, 1, char*);
4005                 s += sizeof(char*);
4006             }
4007             sv = NEWSV(44, 0);
4008             if (aptr)
4009                 sv_setpvn(sv, aptr, len);
4010             PUSHs(sv_2mortal(sv));
4011             break;
4012 #ifdef HAS_QUAD
4013         case 'q':
4014             along = (strend - s) / sizeof(Quad_t);
4015             if (len > along)
4016                 len = along;
4017             EXTEND(SP, len);
4018             EXTEND_MORTAL(len);
4019             while (len-- > 0) {
4020                 if (s + sizeof(Quad_t) > strend)
4021                     aquad = 0;
4022                 else {
4023                     Copy(s, &aquad, 1, Quad_t);
4024                     s += sizeof(Quad_t);
4025                 }
4026                 sv = NEWSV(42, 0);
4027                 if (aquad >= IV_MIN && aquad <= IV_MAX)
4028                     sv_setiv(sv, (IV)aquad);
4029                 else
4030                     sv_setnv(sv, (NV)aquad);
4031                 PUSHs(sv_2mortal(sv));
4032             }
4033             break;
4034         case 'Q':
4035             along = (strend - s) / sizeof(Quad_t);
4036             if (len > along)
4037                 len = along;
4038             EXTEND(SP, len);
4039             EXTEND_MORTAL(len);
4040             while (len-- > 0) {
4041                 if (s + sizeof(Uquad_t) > strend)
4042                     auquad = 0;
4043                 else {
4044                     Copy(s, &auquad, 1, Uquad_t);
4045                     s += sizeof(Uquad_t);
4046                 }
4047                 sv = NEWSV(43, 0);
4048                 if (auquad <= UV_MAX)
4049                     sv_setuv(sv, (UV)auquad);
4050                 else
4051                     sv_setnv(sv, (NV)auquad);
4052                 PUSHs(sv_2mortal(sv));
4053             }
4054             break;
4055 #endif
4056         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4057         case 'f':
4058         case 'F':
4059             along = (strend - s) / sizeof(float);
4060             if (len > along)
4061                 len = along;
4062             if (checksum) {
4063                 while (len-- > 0) {
4064                     Copy(s, &afloat, 1, float);
4065                     s += sizeof(float);
4066                     cdouble += afloat;
4067                 }
4068             }
4069             else {
4070                 EXTEND(SP, len);
4071                 EXTEND_MORTAL(len);
4072                 while (len-- > 0) {
4073                     Copy(s, &afloat, 1, float);
4074                     s += sizeof(float);
4075                     sv = NEWSV(47, 0);
4076                     sv_setnv(sv, (NV)afloat);
4077                     PUSHs(sv_2mortal(sv));
4078                 }
4079             }
4080             break;
4081         case 'd':
4082         case 'D':
4083             along = (strend - s) / sizeof(double);
4084             if (len > along)
4085                 len = along;
4086             if (checksum) {
4087                 while (len-- > 0) {
4088                     Copy(s, &adouble, 1, double);
4089                     s += sizeof(double);
4090                     cdouble += adouble;
4091                 }
4092             }
4093             else {
4094                 EXTEND(SP, len);
4095                 EXTEND_MORTAL(len);
4096                 while (len-- > 0) {
4097                     Copy(s, &adouble, 1, double);
4098                     s += sizeof(double);
4099                     sv = NEWSV(48, 0);
4100                     sv_setnv(sv, (NV)adouble);
4101                     PUSHs(sv_2mortal(sv));
4102                 }
4103             }
4104             break;
4105         case 'u':
4106             /* MKS:
4107              * Initialise the decode mapping.  By using a table driven
4108              * algorithm, the code will be character-set independent
4109              * (and just as fast as doing character arithmetic)
4110              */
4111             if (PL_uudmap['M'] == 0) {
4112                 int i;
4113
4114                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4115                     PL_uudmap[PL_uuemap[i]] = i;
4116                 /*
4117                  * Because ' ' and '`' map to the same value,
4118                  * we need to decode them both the same.
4119                  */
4120                 PL_uudmap[' '] = 0;
4121             }
4122
4123             along = (strend - s) * 3 / 4;
4124             sv = NEWSV(42, along);
4125             if (along)
4126                 SvPOK_on(sv);
4127             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4128                 I32 a, b, c, d;
4129                 char hunk[4];
4130
4131                 hunk[3] = '\0';
4132                 len = PL_uudmap[*s++] & 077;
4133                 while (len > 0) {
4134                     if (s < strend && ISUUCHAR(*s))
4135                         a = PL_uudmap[*s++] & 077;
4136                     else
4137                         a = 0;
4138                     if (s < strend && ISUUCHAR(*s))
4139                         b = PL_uudmap[*s++] & 077;
4140                     else
4141                         b = 0;
4142                     if (s < strend && ISUUCHAR(*s))
4143                         c = PL_uudmap[*s++] & 077;
4144                     else
4145                         c = 0;
4146                     if (s < strend && ISUUCHAR(*s))
4147                         d = PL_uudmap[*s++] & 077;
4148                     else
4149                         d = 0;
4150                     hunk[0] = (a << 2) | (b >> 4);
4151                     hunk[1] = (b << 4) | (c >> 2);
4152                     hunk[2] = (c << 6) | d;
4153                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4154                     len -= 3;
4155                 }
4156                 if (*s == '\n')
4157                     s++;
4158                 else if (s[1] == '\n')          /* possible checksum byte */
4159                     s += 2;
4160             }
4161             XPUSHs(sv_2mortal(sv));
4162             break;
4163         }
4164         if (checksum) {
4165             sv = NEWSV(42, 0);
4166             if (strchr("fFdD", datumtype) ||
4167               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4168                 NV trouble;
4169
4170                 adouble = 1.0;
4171                 while (checksum >= 16) {
4172                     checksum -= 16;
4173                     adouble *= 65536.0;
4174                 }
4175                 while (checksum >= 4) {
4176                     checksum -= 4;
4177                     adouble *= 16.0;
4178                 }
4179                 while (checksum--)
4180                     adouble *= 2.0;
4181                 along = (1 << checksum) - 1;
4182                 while (cdouble < 0.0)
4183                     cdouble += adouble;
4184                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4185                 sv_setnv(sv, cdouble);
4186             }
4187             else {
4188                 if (checksum < 32) {
4189                     aulong = (1 << checksum) - 1;
4190                     culong &= aulong;
4191                 }
4192                 sv_setuv(sv, (UV)culong);
4193             }
4194             XPUSHs(sv_2mortal(sv));
4195             checksum = 0;
4196         }
4197     }
4198     if (SP == oldsp && gimme == G_SCALAR)
4199         PUSHs(&PL_sv_undef);
4200     RETURN;
4201 }
4202
4203 STATIC void
4204 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4205 {
4206     char hunk[5];
4207
4208     *hunk = PL_uuemap[len];
4209     sv_catpvn(sv, hunk, 1);
4210     hunk[4] = '\0';
4211     while (len > 2) {
4212         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4213         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4214         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4215         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4216         sv_catpvn(sv, hunk, 4);
4217         s += 3;
4218         len -= 3;
4219     }
4220     if (len > 0) {
4221         char r = (len > 1 ? s[1] : '\0');
4222         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4223         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4224         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4225         hunk[3] = PL_uuemap[0];
4226         sv_catpvn(sv, hunk, 4);
4227     }
4228     sv_catpvn(sv, "\n", 1);
4229 }
4230
4231 STATIC SV *
4232 S_is_an_int(pTHX_ char *s, STRLEN l)
4233 {
4234   STRLEN         n_a;
4235   SV             *result = newSVpvn(s, l);
4236   char           *result_c = SvPV(result, n_a); /* convenience */
4237   char           *out = result_c;
4238   bool            skip = 1;
4239   bool            ignore = 0;
4240
4241   while (*s) {
4242     switch (*s) {
4243     case ' ':
4244       break;
4245     case '+':
4246       if (!skip) {
4247         SvREFCNT_dec(result);
4248         return (NULL);
4249       }
4250       break;
4251     case '0':
4252     case '1':
4253     case '2':
4254     case '3':
4255     case '4':
4256     case '5':
4257     case '6':
4258     case '7':
4259     case '8':
4260     case '9':
4261       skip = 0;
4262       if (!ignore) {
4263         *(out++) = *s;
4264       }
4265       break;
4266     case '.':
4267       ignore = 1;
4268       break;
4269     default:
4270       SvREFCNT_dec(result);
4271       return (NULL);
4272     }
4273     s++;
4274   }
4275   *(out++) = '\0';
4276   SvCUR_set(result, out - result_c);
4277   return (result);
4278 }
4279
4280 /* pnum must be '\0' terminated */
4281 STATIC int
4282 S_div128(pTHX_ SV *pnum, bool *done)
4283 {
4284   STRLEN          len;
4285   char           *s = SvPV(pnum, len);
4286   int             m = 0;
4287   int             r = 0;
4288   char           *t = s;
4289
4290   *done = 1;
4291   while (*t) {
4292     int             i;
4293
4294     i = m * 10 + (*t - '0');
4295     m = i & 0x7F;
4296     r = (i >> 7);               /* r < 10 */
4297     if (r) {
4298       *done = 0;
4299     }
4300     *(t++) = '0' + r;
4301   }
4302   *(t++) = '\0';
4303   SvCUR_set(pnum, (STRLEN) (t - s));
4304   return (m);
4305 }
4306
4307
4308 PP(pp_pack)
4309 {
4310     djSP; dMARK; dORIGMARK; dTARGET;
4311     register SV *cat = TARG;
4312     register I32 items;
4313     STRLEN fromlen;
4314     register char *pat = SvPVx(*++MARK, fromlen);
4315     register char *patend = pat + fromlen;
4316     register I32 len;
4317     I32 datumtype;
4318     SV *fromstr;
4319     /*SUPPRESS 442*/
4320     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4321     static char *space10 = "          ";
4322
4323     /* These must not be in registers: */
4324     char achar;
4325     I16 ashort;
4326     int aint;
4327     unsigned int auint;
4328     I32 along;
4329     U32 aulong;
4330 #ifdef HAS_QUAD
4331     Quad_t aquad;
4332     Uquad_t auquad;
4333 #endif
4334     char *aptr;
4335     float afloat;
4336     double adouble;
4337     int commas = 0;
4338 #ifdef PERL_NATINT_PACK
4339     int natint;         /* native integer */
4340 #endif
4341
4342     items = SP - MARK;
4343     MARK++;
4344     sv_setpvn(cat, "", 0);
4345     while (pat < patend) {
4346         SV *lengthcode = Nullsv;
4347 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4348         datumtype = *pat++ & 0xFF;
4349 #ifdef PERL_NATINT_PACK
4350         natint = 0;
4351 #endif
4352         if (isSPACE(datumtype))
4353             continue;
4354         if (datumtype == '#') {
4355             while (pat < patend && *pat != '\n')
4356                 pat++;
4357             continue;
4358         }
4359         if (*pat == '!') {
4360             char *natstr = "sSiIlL";
4361
4362             if (strchr(natstr, datumtype)) {
4363 #ifdef PERL_NATINT_PACK
4364                 natint = 1;
4365 #endif
4366                 pat++;
4367             }
4368             else
4369                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4370         }
4371         if (*pat == '*') {
4372             len = strchr("@Xxu", datumtype) ? 0 : items;
4373             pat++;
4374         }
4375         else if (isDIGIT(*pat)) {
4376             len = *pat++ - '0';
4377             while (isDIGIT(*pat)) {
4378                 len = (len * 10) + (*pat++ - '0');
4379                 if (len < 0)
4380                     DIE(aTHX_ "Repeat count in pack overflows");
4381             }
4382         }
4383         else
4384             len = 1;
4385         if (*pat == '/') {
4386             ++pat;
4387             if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4388                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4389             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4390                                                    ? *MARK : &PL_sv_no)));
4391         }
4392         switch(datumtype) {
4393         default:
4394             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4395         case ',': /* grandfather in commas but with a warning */
4396             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4397                 Perl_warner(aTHX_ WARN_UNSAFE,
4398                             "Invalid type in pack: '%c'", (int)datumtype);
4399             break;
4400         case '%':
4401             DIE(aTHX_ "%% may only be used in unpack");
4402         case '@':
4403             len -= SvCUR(cat);
4404             if (len > 0)
4405                 goto grow;
4406             len = -len;
4407             if (len > 0)
4408                 goto shrink;
4409             break;
4410         case 'X':
4411           shrink:
4412             if (SvCUR(cat) < len)
4413                 DIE(aTHX_ "X outside of string");
4414             SvCUR(cat) -= len;
4415             *SvEND(cat) = '\0';
4416             break;
4417         case 'x':
4418           grow:
4419             while (len >= 10) {
4420                 sv_catpvn(cat, null10, 10);
4421                 len -= 10;
4422             }
4423             sv_catpvn(cat, null10, len);
4424             break;
4425         case 'A':
4426         case 'Z':
4427         case 'a':
4428             fromstr = NEXTFROM;
4429             aptr = SvPV(fromstr, fromlen);
4430             if (pat[-1] == '*') {
4431                 len = fromlen;
4432                 if (datumtype == 'Z')
4433                     ++len;
4434             }
4435             if (fromlen >= len) {
4436                 sv_catpvn(cat, aptr, len);
4437                 if (datumtype == 'Z')
4438                     *(SvEND(cat)-1) = '\0';
4439             }
4440             else {
4441                 sv_catpvn(cat, aptr, fromlen);
4442                 len -= fromlen;
4443                 if (datumtype == 'A') {
4444                     while (len >= 10) {
4445                         sv_catpvn(cat, space10, 10);
4446                         len -= 10;
4447                     }
4448                     sv_catpvn(cat, space10, len);
4449                 }
4450                 else {
4451                     while (len >= 10) {
4452                         sv_catpvn(cat, null10, 10);
4453                         len -= 10;
4454                     }
4455                     sv_catpvn(cat, null10, len);
4456                 }
4457             }
4458             break;
4459         case 'B':
4460         case 'b':
4461             {
4462                 char *savepat = pat;
4463                 I32 saveitems;
4464
4465                 fromstr = NEXTFROM;
4466                 saveitems = items;
4467                 aptr = SvPV(fromstr, fromlen);
4468                 if (pat[-1] == '*')
4469                     len = fromlen;
4470                 pat = aptr;
4471                 aint = SvCUR(cat);
4472                 SvCUR(cat) += (len+7)/8;
4473                 SvGROW(cat, SvCUR(cat) + 1);
4474                 aptr = SvPVX(cat) + aint;
4475                 if (len > fromlen)
4476                     len = fromlen;
4477                 aint = len;
4478                 items = 0;
4479                 if (datumtype == 'B') {
4480                     for (len = 0; len++ < aint;) {
4481                         items |= *pat++ & 1;
4482                         if (len & 7)
4483                             items <<= 1;
4484                         else {
4485                             *aptr++ = items & 0xff;
4486                             items = 0;
4487                         }
4488                     }
4489                 }
4490                 else {
4491                     for (len = 0; len++ < aint;) {
4492                         if (*pat++ & 1)
4493                             items |= 128;
4494                         if (len & 7)
4495                             items >>= 1;
4496                         else {
4497                             *aptr++ = items & 0xff;
4498                             items = 0;
4499                         }
4500                     }
4501                 }
4502                 if (aint & 7) {
4503                     if (datumtype == 'B')
4504                         items <<= 7 - (aint & 7);
4505                     else
4506                         items >>= 7 - (aint & 7);
4507                     *aptr++ = items & 0xff;
4508                 }
4509                 pat = SvPVX(cat) + SvCUR(cat);
4510                 while (aptr <= pat)
4511                     *aptr++ = '\0';
4512
4513                 pat = savepat;
4514                 items = saveitems;
4515             }
4516             break;
4517         case 'H':
4518         case 'h':
4519             {
4520                 char *savepat = pat;
4521                 I32 saveitems;
4522
4523                 fromstr = NEXTFROM;
4524                 saveitems = items;
4525                 aptr = SvPV(fromstr, fromlen);
4526                 if (pat[-1] == '*')
4527                     len = fromlen;
4528                 pat = aptr;
4529                 aint = SvCUR(cat);
4530                 SvCUR(cat) += (len+1)/2;
4531                 SvGROW(cat, SvCUR(cat) + 1);
4532                 aptr = SvPVX(cat) + aint;
4533                 if (len > fromlen)
4534                     len = fromlen;
4535                 aint = len;
4536                 items = 0;
4537                 if (datumtype == 'H') {
4538                     for (len = 0; len++ < aint;) {
4539                         if (isALPHA(*pat))
4540                             items |= ((*pat++ & 15) + 9) & 15;
4541                         else
4542                             items |= *pat++ & 15;
4543                         if (len & 1)
4544                             items <<= 4;
4545                         else {
4546                             *aptr++ = items & 0xff;
4547                             items = 0;
4548                         }
4549                     }
4550                 }
4551                 else {
4552                     for (len = 0; len++ < aint;) {
4553                         if (isALPHA(*pat))
4554                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4555                         else
4556                             items |= (*pat++ & 15) << 4;
4557                         if (len & 1)
4558                             items >>= 4;
4559                         else {
4560                             *aptr++ = items & 0xff;
4561                             items = 0;
4562                         }
4563                     }
4564                 }
4565                 if (aint & 1)
4566                     *aptr++ = items & 0xff;
4567                 pat = SvPVX(cat) + SvCUR(cat);
4568                 while (aptr <= pat)
4569                     *aptr++ = '\0';
4570
4571                 pat = savepat;
4572                 items = saveitems;
4573             }
4574             break;
4575         case 'C':
4576         case 'c':
4577             while (len-- > 0) {
4578                 fromstr = NEXTFROM;
4579                 aint = SvIV(fromstr);
4580                 achar = aint;
4581                 sv_catpvn(cat, &achar, sizeof(char));
4582             }
4583             break;
4584         case 'U':
4585             while (len-- > 0) {
4586                 fromstr = NEXTFROM;
4587                 auint = SvUV(fromstr);
4588                 SvGROW(cat, SvCUR(cat) + 10);
4589                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4590                                - SvPVX(cat));
4591             }
4592             *SvEND(cat) = '\0';
4593             break;
4594         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4595         case 'f':
4596         case 'F':
4597             while (len-- > 0) {
4598                 fromstr = NEXTFROM;
4599                 afloat = (float)SvNV(fromstr);
4600                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4601             }
4602             break;
4603         case 'd':
4604         case 'D':
4605             while (len-- > 0) {
4606                 fromstr = NEXTFROM;
4607                 adouble = (double)SvNV(fromstr);
4608                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4609             }
4610             break;
4611         case 'n':
4612             while (len-- > 0) {
4613                 fromstr = NEXTFROM;
4614                 ashort = (I16)SvIV(fromstr);
4615 #ifdef HAS_HTONS
4616                 ashort = PerlSock_htons(ashort);
4617 #endif
4618                 CAT16(cat, &ashort);
4619             }
4620             break;
4621         case 'v':
4622             while (len-- > 0) {
4623                 fromstr = NEXTFROM;
4624                 ashort = (I16)SvIV(fromstr);
4625 #ifdef HAS_HTOVS
4626                 ashort = htovs(ashort);
4627 #endif
4628                 CAT16(cat, &ashort);
4629             }
4630             break;
4631         case 'S':
4632 #if SHORTSIZE != SIZE16
4633             if (natint) {
4634                 unsigned short aushort;
4635
4636                 while (len-- > 0) {
4637                     fromstr = NEXTFROM;
4638                     aushort = SvUV(fromstr);
4639                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4640                 }
4641             }
4642             else
4643 #endif
4644             {
4645                 U16 aushort;
4646
4647                 while (len-- > 0) {
4648                     fromstr = NEXTFROM;
4649                     aushort = (U16)SvUV(fromstr);
4650                     CAT16(cat, &aushort);
4651                 }
4652
4653             }
4654             break;
4655         case 's':
4656 #if SHORTSIZE != SIZE16
4657             if (natint) {
4658                 short ashort;
4659
4660                 while (len-- > 0) {
4661                     fromstr = NEXTFROM;
4662                     ashort = SvIV(fromstr);
4663                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
4664                 }
4665             }
4666             else
4667 #endif
4668             {
4669                 while (len-- > 0) {
4670                     fromstr = NEXTFROM;
4671                     ashort = (I16)SvIV(fromstr);
4672                     CAT16(cat, &ashort);
4673                 }
4674             }
4675             break;
4676         case 'I':
4677             while (len-- > 0) {
4678                 fromstr = NEXTFROM;
4679                 auint = SvUV(fromstr);
4680                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4681             }
4682             break;
4683         case 'w':
4684             while (len-- > 0) {
4685                 fromstr = NEXTFROM;
4686                 adouble = Perl_floor(SvNV(fromstr));
4687
4688                 if (adouble < 0)
4689                     DIE(aTHX_ "Cannot compress negative numbers");
4690
4691                 if (
4692 #ifdef BW_BITS
4693                     adouble <= BW_MASK
4694 #else
4695 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4696                     adouble <= UV_MAX_cxux
4697 #else
4698                     adouble <= UV_MAX
4699 #endif
4700 #endif
4701                     )
4702                 {
4703                     char   buf[1 + sizeof(UV)];
4704                     char  *in = buf + sizeof(buf);
4705                     UV     auv = U_V(adouble);
4706
4707                     do {
4708                         *--in = (auv & 0x7f) | 0x80;
4709                         auv >>= 7;
4710                     } while (auv);
4711                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4712                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4713                 }
4714                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4715                     char           *from, *result, *in;
4716                     SV             *norm;
4717                     STRLEN          len;
4718                     bool            done;
4719
4720                     /* Copy string and check for compliance */
4721                     from = SvPV(fromstr, len);
4722                     if ((norm = is_an_int(from, len)) == NULL)
4723                         DIE(aTHX_ "can compress only unsigned integer");
4724
4725                     New('w', result, len, char);
4726                     in = result + len;
4727                     done = FALSE;
4728                     while (!done)
4729                         *--in = div128(norm, &done) | 0x80;
4730                     result[len - 1] &= 0x7F; /* clear continue bit */
4731                     sv_catpvn(cat, in, (result + len) - in);
4732                     Safefree(result);
4733                     SvREFCNT_dec(norm); /* free norm */
4734                 }
4735                 else if (SvNOKp(fromstr)) {
4736                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4737                     char  *in = buf + sizeof(buf);
4738
4739                     do {
4740                         double next = floor(adouble / 128);
4741                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4742                         if (--in < buf)  /* this cannot happen ;-) */
4743                             DIE(aTHX_ "Cannot compress integer");
4744                         adouble = next;
4745                     } while (adouble > 0);
4746                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4747                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4748                 }
4749                 else
4750                     DIE(aTHX_ "Cannot compress non integer");
4751             }
4752             break;
4753         case 'i':
4754             while (len-- > 0) {
4755                 fromstr = NEXTFROM;
4756                 aint = SvIV(fromstr);
4757                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4758             }
4759             break;
4760         case 'N':
4761             while (len-- > 0) {
4762                 fromstr = NEXTFROM;
4763                 aulong = SvUV(fromstr);
4764 #ifdef HAS_HTONL
4765                 aulong = PerlSock_htonl(aulong);
4766 #endif
4767                 CAT32(cat, &aulong);
4768             }
4769             break;
4770         case 'V':
4771             while (len-- > 0) {
4772                 fromstr = NEXTFROM;
4773                 aulong = SvUV(fromstr);
4774 #ifdef HAS_HTOVL
4775                 aulong = htovl(aulong);
4776 #endif
4777                 CAT32(cat, &aulong);
4778             }
4779             break;
4780         case 'L':
4781 #if LONGSIZE != SIZE32
4782             if (natint) {
4783                 unsigned long aulong;
4784
4785                 while (len-- > 0) {
4786                     fromstr = NEXTFROM;
4787                     aulong = SvUV(fromstr);
4788                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4789                 }
4790             }
4791             else
4792 #endif
4793             {
4794                 while (len-- > 0) {
4795                     fromstr = NEXTFROM;
4796                     aulong = SvUV(fromstr);
4797                     CAT32(cat, &aulong);
4798                 }
4799             }
4800             break;
4801         case 'l':
4802 #if LONGSIZE != SIZE32
4803             if (natint) {
4804                 long along;
4805
4806                 while (len-- > 0) {
4807                     fromstr = NEXTFROM;
4808                     along = SvIV(fromstr);
4809                     sv_catpvn(cat, (char *)&along, sizeof(long));
4810                 }
4811             }
4812             else
4813 #endif
4814             {
4815                 while (len-- > 0) {
4816                     fromstr = NEXTFROM;
4817                     along = SvIV(fromstr);
4818                     CAT32(cat, &along);
4819                 }
4820             }
4821             break;
4822 #ifdef HAS_QUAD
4823         case 'Q':
4824             while (len-- > 0) {
4825                 fromstr = NEXTFROM;
4826                 auquad = (Uquad_t)SvUV(fromstr);
4827                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4828             }
4829             break;
4830         case 'q':
4831             while (len-- > 0) {
4832                 fromstr = NEXTFROM;
4833                 aquad = (Quad_t)SvIV(fromstr);
4834                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4835             }
4836             break;
4837 #endif /* HAS_QUAD */
4838         case 'P':
4839             len = 1;            /* assume SV is correct length */
4840             /* FALL THROUGH */
4841         case 'p':
4842             while (len-- > 0) {
4843                 fromstr = NEXTFROM;
4844                 if (fromstr == &PL_sv_undef)
4845                     aptr = NULL;
4846                 else {
4847                     STRLEN n_a;
4848                     /* XXX better yet, could spirit away the string to
4849                      * a safe spot and hang on to it until the result
4850                      * of pack() (and all copies of the result) are
4851                      * gone.
4852                      */
4853                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4854                         Perl_warner(aTHX_ WARN_UNSAFE,
4855                                 "Attempt to pack pointer to temporary value");
4856                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4857                         aptr = SvPV(fromstr,n_a);
4858                     else
4859                         aptr = SvPV_force(fromstr,n_a);
4860                 }
4861                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4862             }
4863             break;
4864         case 'u':
4865             fromstr = NEXTFROM;
4866             aptr = SvPV(fromstr, fromlen);
4867             SvGROW(cat, fromlen * 4 / 3);
4868             if (len <= 1)
4869                 len = 45;
4870             else
4871                 len = len / 3 * 3;
4872             while (fromlen > 0) {
4873                 I32 todo;
4874
4875                 if (fromlen > len)
4876                     todo = len;
4877                 else
4878                     todo = fromlen;
4879                 doencodes(cat, aptr, todo);
4880                 fromlen -= todo;
4881                 aptr += todo;
4882             }
4883             break;
4884         }
4885     }
4886     SvSETMAGIC(cat);
4887     SP = ORIGMARK;
4888     PUSHs(cat);
4889     RETURN;
4890 }
4891 #undef NEXTFROM
4892
4893
4894 PP(pp_split)
4895 {
4896     djSP; dTARG;
4897     AV *ary;
4898     register I32 limit = POPi;                  /* note, negative is forever */
4899     SV *sv = POPs;
4900     STRLEN len;
4901     register char *s = SvPV(sv, len);
4902     char *strend = s + len;
4903     register PMOP *pm;
4904     register REGEXP *rx;
4905     register SV *dstr;
4906     register char *m;
4907     I32 iters = 0;
4908     I32 maxiters = (strend - s) + 10;
4909     I32 i;
4910     char *orig;
4911     I32 origlimit = limit;
4912     I32 realarray = 0;
4913     I32 base;
4914     AV *oldstack = PL_curstack;
4915     I32 gimme = GIMME_V;
4916     I32 oldsave = PL_savestack_ix;
4917     I32 make_mortal = 1;
4918     MAGIC *mg = (MAGIC *) NULL;
4919
4920 #ifdef DEBUGGING
4921     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4922 #else
4923     pm = (PMOP*)POPs;
4924 #endif
4925     if (!pm || !s)
4926         DIE(aTHX_ "panic: do_split");
4927     rx = pm->op_pmregexp;
4928
4929     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4930              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4931
4932     if (pm->op_pmreplroot)
4933         ary = GvAVn((GV*)pm->op_pmreplroot);
4934     else if (gimme != G_ARRAY)
4935 #ifdef USE_THREADS
4936         ary = (AV*)PL_curpad[0];
4937 #else
4938         ary = GvAVn(PL_defgv);
4939 #endif /* USE_THREADS */
4940     else
4941         ary = Nullav;
4942     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4943         realarray = 1;
4944         PUTBACK;
4945         av_extend(ary,0);
4946         av_clear(ary);
4947         SPAGAIN;
4948         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4949             PUSHMARK(SP);
4950             XPUSHs(SvTIED_obj((SV*)ary, mg));
4951         }
4952         else {
4953             if (!AvREAL(ary)) {
4954                 AvREAL_on(ary);
4955                 AvREIFY_off(ary);
4956                 for (i = AvFILLp(ary); i >= 0; i--)
4957                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4958             }
4959             /* temporarily switch stacks */
4960             SWITCHSTACK(PL_curstack, ary);
4961             make_mortal = 0;
4962         }
4963     }
4964     base = SP - PL_stack_base;
4965     orig = s;
4966     if (pm->op_pmflags & PMf_SKIPWHITE) {
4967         if (pm->op_pmflags & PMf_LOCALE) {
4968             while (isSPACE_LC(*s))
4969                 s++;
4970         }
4971         else {
4972             while (isSPACE(*s))
4973                 s++;
4974         }
4975     }
4976     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4977         SAVEINT(PL_multiline);
4978         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4979     }
4980
4981     if (!limit)
4982         limit = maxiters + 2;
4983     if (pm->op_pmflags & PMf_WHITE) {
4984         while (--limit) {
4985             m = s;
4986             while (m < strend &&
4987                    !((pm->op_pmflags & PMf_LOCALE)
4988                      ? isSPACE_LC(*m) : isSPACE(*m)))
4989                 ++m;
4990             if (m >= strend)
4991                 break;
4992
4993             dstr = NEWSV(30, m-s);
4994             sv_setpvn(dstr, s, m-s);
4995             if (make_mortal)
4996                 sv_2mortal(dstr);
4997             XPUSHs(dstr);
4998
4999             s = m + 1;
5000             while (s < strend &&
5001                    ((pm->op_pmflags & PMf_LOCALE)
5002                     ? isSPACE_LC(*s) : isSPACE(*s)))
5003                 ++s;
5004         }
5005     }
5006     else if (strEQ("^", rx->precomp)) {
5007         while (--limit) {
5008             /*SUPPRESS 530*/
5009             for (m = s; m < strend && *m != '\n'; m++) ;
5010             m++;
5011             if (m >= strend)
5012                 break;
5013             dstr = NEWSV(30, m-s);
5014             sv_setpvn(dstr, s, m-s);
5015             if (make_mortal)
5016                 sv_2mortal(dstr);
5017             XPUSHs(dstr);
5018             s = m;
5019         }
5020     }
5021     else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5022              && (rx->reganch & ROPT_CHECK_ALL)
5023              && !(rx->reganch & ROPT_ANCH)) {
5024         int tail = (rx->reganch & RE_INTUIT_TAIL);
5025         SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5026         char c;
5027
5028         len = rx->minlen;
5029         if (len == 1 && !tail) {
5030             c = *SvPV(csv,len);
5031             while (--limit) {
5032                 /*SUPPRESS 530*/
5033                 for (m = s; m < strend && *m != c; m++) ;
5034                 if (m >= strend)
5035                     break;
5036                 dstr = NEWSV(30, m-s);
5037                 sv_setpvn(dstr, s, m-s);
5038                 if (make_mortal)
5039                     sv_2mortal(dstr);
5040                 XPUSHs(dstr);
5041                 s = m + 1;
5042             }
5043         }
5044         else {
5045 #ifndef lint
5046             while (s < strend && --limit &&
5047               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5048                              csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5049 #endif
5050             {
5051                 dstr = NEWSV(31, m-s);
5052                 sv_setpvn(dstr, s, m-s);
5053                 if (make_mortal)
5054                     sv_2mortal(dstr);
5055                 XPUSHs(dstr);
5056                 s = m + len;            /* Fake \n at the end */
5057             }
5058         }
5059     }
5060     else {
5061         maxiters += (strend - s) * rx->nparens;
5062         while (s < strend && --limit
5063 /*             && (!rx->check_substr
5064                    || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5065                                                  0, NULL))))
5066 */             && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5067                               1 /* minend */, sv, NULL, 0))
5068         {
5069             TAINT_IF(RX_MATCH_TAINTED(rx));
5070             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5071                 m = s;
5072                 s = orig;
5073                 orig = rx->subbeg;
5074                 s = orig + (m - s);
5075                 strend = s + (strend - m);
5076             }
5077             m = rx->startp[0] + orig;
5078             dstr = NEWSV(32, m-s);
5079             sv_setpvn(dstr, s, m-s);
5080             if (make_mortal)
5081                 sv_2mortal(dstr);
5082             XPUSHs(dstr);
5083             if (rx->nparens) {
5084                 for (i = 1; i <= rx->nparens; i++) {
5085                     s = rx->startp[i] + orig;
5086                     m = rx->endp[i] + orig;
5087                     if (m && s) {
5088                         dstr = NEWSV(33, m-s);
5089                         sv_setpvn(dstr, s, m-s);
5090                     }
5091                     else
5092                         dstr = NEWSV(33, 0);
5093                     if (make_mortal)
5094                         sv_2mortal(dstr);
5095                     XPUSHs(dstr);
5096                 }
5097             }
5098             s = rx->endp[0] + orig;
5099         }
5100     }
5101
5102     LEAVE_SCOPE(oldsave);
5103     iters = (SP - PL_stack_base) - base;
5104     if (iters > maxiters)
5105         DIE(aTHX_ "Split loop");
5106
5107     /* keep field after final delim? */
5108     if (s < strend || (iters && origlimit)) {
5109         dstr = NEWSV(34, strend-s);
5110         sv_setpvn(dstr, s, strend-s);
5111         if (make_mortal)
5112             sv_2mortal(dstr);
5113         XPUSHs(dstr);
5114         iters++;
5115     }
5116     else if (!origlimit) {
5117         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5118             iters--, SP--;
5119     }
5120
5121     if (realarray) {
5122         if (!mg) {
5123             SWITCHSTACK(ary, oldstack);
5124             if (SvSMAGICAL(ary)) {
5125                 PUTBACK;
5126                 mg_set((SV*)ary);
5127                 SPAGAIN;
5128             }
5129             if (gimme == G_ARRAY) {
5130                 EXTEND(SP, iters);
5131                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5132                 SP += iters;
5133                 RETURN;
5134             }
5135         }
5136         else {
5137             PUTBACK;
5138             ENTER;
5139             call_method("PUSH",G_SCALAR|G_DISCARD);
5140             LEAVE;
5141             SPAGAIN;
5142             if (gimme == G_ARRAY) {
5143                 /* EXTEND should not be needed - we just popped them */
5144                 EXTEND(SP, iters);
5145                 for (i=0; i < iters; i++) {
5146                     SV **svp = av_fetch(ary, i, FALSE);
5147                     PUSHs((svp) ? *svp : &PL_sv_undef);
5148                 }
5149                 RETURN;
5150             }
5151         }
5152     }
5153     else {
5154         if (gimme == G_ARRAY)
5155             RETURN;
5156     }
5157     if (iters || !pm->op_pmreplroot) {
5158         GETTARGET;
5159         PUSHi(iters);
5160         RETURN;
5161     }
5162     RETPUSHUNDEF;
5163 }
5164
5165 #ifdef USE_THREADS
5166 void
5167 Perl_unlock_condpair(pTHX_ void *svv)
5168 {
5169     dTHR;
5170     MAGIC *mg = mg_find((SV*)svv, 'm');
5171
5172     if (!mg)
5173         Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5174     MUTEX_LOCK(MgMUTEXP(mg));
5175     if (MgOWNER(mg) != thr)
5176         Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5177     MgOWNER(mg) = 0;
5178     COND_SIGNAL(MgOWNERCONDP(mg));
5179     DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: unlock 0x%lx\n",
5180                           (unsigned long)thr, (unsigned long)svv);)
5181     MUTEX_UNLOCK(MgMUTEXP(mg));
5182 }
5183 #endif /* USE_THREADS */
5184
5185 PP(pp_lock)
5186 {
5187     djSP;
5188     dTOPss;
5189     SV *retsv = sv;
5190 #ifdef USE_THREADS
5191     MAGIC *mg;
5192
5193     if (SvROK(sv))
5194         sv = SvRV(sv);
5195
5196     mg = condpair_magic(sv);
5197     MUTEX_LOCK(MgMUTEXP(mg));
5198     if (MgOWNER(mg) == thr)
5199         MUTEX_UNLOCK(MgMUTEXP(mg));
5200     else {
5201         while (MgOWNER(mg))
5202             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5203         MgOWNER(mg) = thr;
5204         DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: pp_lock lock 0x%lx\n",
5205                               (unsigned long)thr, (unsigned long)sv);)
5206         MUTEX_UNLOCK(MgMUTEXP(mg));
5207         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5208     }
5209 #endif /* USE_THREADS */
5210     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5211         || SvTYPE(retsv) == SVt_PVCV) {
5212         retsv = refto(retsv);
5213     }
5214     SETs(retsv);
5215     RETURN;
5216 }
5217
5218 PP(pp_threadsv)
5219 {
5220     djSP;
5221 #ifdef USE_THREADS
5222     EXTEND(SP, 1);
5223     if (PL_op->op_private & OPpLVAL_INTRO)
5224         PUSHs(*save_threadsv(PL_op->op_targ));
5225     else
5226         PUSHs(THREADSV(PL_op->op_targ));
5227     RETURN;
5228 #else
5229     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5230 #endif /* USE_THREADS */
5231 }