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