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