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