pp.c

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