pp.c

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