pp.c

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