pp.c

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