pp.c

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