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