pp.c

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