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