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