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