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