pp.c

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