pp.c

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