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