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) && AvREIFY(ary))
2857         av_reify(ary);
2858
2859     if (diff < 0) {                             /* shrinking the area */
2860         if (newlen) {
2861             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2862             Copy(MARK, tmparyval, newlen, SV*);
2863         }
2864
2865         MARK = ORIGMARK + 1;
2866         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2867             MEXTEND(MARK, length);
2868             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2869             if (AvREAL(ary)) {
2870                 EXTEND_MORTAL(length);
2871                 for (i = length, dst = MARK; i; i--) {
2872                     sv_2mortal(*dst);   /* free them eventualy */
2873                     dst++;
2874                 }
2875             }
2876             MARK += length - 1;
2877         }
2878         else {
2879             *MARK = AvARRAY(ary)[offset+length-1];
2880             if (AvREAL(ary)) {
2881                 sv_2mortal(*MARK);
2882                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2883                     SvREFCNT_dec(*dst++);       /* free them now */
2884             }
2885         }
2886         AvFILLp(ary) += diff;
2887
2888         /* pull up or down? */
2889
2890         if (offset < after) {                   /* easier to pull up */
2891             if (offset) {                       /* esp. if nothing to pull */
2892                 src = &AvARRAY(ary)[offset-1];
2893                 dst = src - diff;               /* diff is negative */
2894                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2895                     *dst-- = *src--;
2896             }
2897             dst = AvARRAY(ary);
2898             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2899             AvMAX(ary) += diff;
2900         }
2901         else {
2902             if (after) {                        /* anything to pull down? */
2903                 src = AvARRAY(ary) + offset + length;
2904                 dst = src + diff;               /* diff is negative */
2905                 Move(src, dst, after, SV*);
2906             }
2907             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2908                                                 /* avoid later double free */
2909         }
2910         i = -diff;
2911         while (i)
2912             dst[--i] = &PL_sv_undef;
2913
2914         if (newlen) {
2915             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2916               newlen; newlen--) {
2917                 *dst = NEWSV(46, 0);
2918                 sv_setsv(*dst++, *src++);
2919             }
2920             Safefree(tmparyval);
2921         }
2922     }
2923     else {                                      /* no, expanding (or same) */
2924         if (length) {
2925             New(452, tmparyval, length, SV*);   /* so remember deletion */
2926             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2927         }
2928
2929         if (diff > 0) {                         /* expanding */
2930
2931             /* push up or down? */
2932
2933             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2934                 if (offset) {
2935                     src = AvARRAY(ary);
2936                     dst = src - diff;
2937                     Move(src, dst, offset, SV*);
2938                 }
2939                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2940                 AvMAX(ary) += diff;
2941                 AvFILLp(ary) += diff;
2942             }
2943             else {
2944                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2945                     av_extend(ary, AvFILLp(ary) + diff);
2946                 AvFILLp(ary) += diff;
2947
2948                 if (after) {
2949                     dst = AvARRAY(ary) + AvFILLp(ary);
2950                     src = dst - diff;
2951                     for (i = after; i; i--) {
2952                         *dst-- = *src--;
2953                     }
2954                 }
2955             }
2956         }
2957
2958         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2959             *dst = NEWSV(46, 0);
2960             sv_setsv(*dst++, *src++);
2961         }
2962         MARK = ORIGMARK + 1;
2963         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2964             if (length) {
2965                 Copy(tmparyval, MARK, length, SV*);
2966                 if (AvREAL(ary)) {
2967                     EXTEND_MORTAL(length);
2968                     for (i = length, dst = MARK; i; i--) {
2969                         sv_2mortal(*dst);       /* free them eventualy */
2970                         dst++;
2971                     }
2972                 }
2973                 Safefree(tmparyval);
2974             }
2975             MARK += length - 1;
2976         }
2977         else if (length--) {
2978             *MARK = tmparyval[length];
2979             if (AvREAL(ary)) {
2980                 sv_2mortal(*MARK);
2981                 while (length-- > 0)
2982                     SvREFCNT_dec(tmparyval[length]);
2983             }
2984             Safefree(tmparyval);
2985         }
2986         else
2987             *MARK = &PL_sv_undef;
2988     }
2989     SP = MARK;
2990     RETURN;
2991 }
2992
2993 PP(pp_push)
2994 {
2995     djSP; dMARK; dORIGMARK; dTARGET;
2996     register AV *ary = (AV*)*++MARK;
2997     register SV *sv = &PL_sv_undef;
2998     MAGIC *mg;
2999
3000     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3001         *MARK-- = SvTIED_obj((SV*)ary, mg);
3002         PUSHMARK(MARK);
3003         PUTBACK;
3004         ENTER;
3005         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3006         LEAVE;
3007         SPAGAIN;
3008     }
3009     else {
3010         /* Why no pre-extend of ary here ? */
3011         for (++MARK; MARK <= SP; MARK++) {
3012             sv = NEWSV(51, 0);
3013             if (*MARK)
3014                 sv_setsv(sv, *MARK);
3015             av_push(ary, sv);
3016         }
3017     }
3018     SP = ORIGMARK;
3019     PUSHi( AvFILL(ary) + 1 );
3020     RETURN;
3021 }
3022
3023 PP(pp_pop)
3024 {
3025     djSP;
3026     AV *av = (AV*)POPs;
3027     SV *sv = av_pop(av);
3028     if (AvREAL(av))
3029         (void)sv_2mortal(sv);
3030     PUSHs(sv);
3031     RETURN;
3032 }
3033
3034 PP(pp_shift)
3035 {
3036     djSP;
3037     AV *av = (AV*)POPs;
3038     SV *sv = av_shift(av);
3039     EXTEND(SP, 1);
3040     if (!sv)
3041         RETPUSHUNDEF;
3042     if (AvREAL(av))
3043         (void)sv_2mortal(sv);
3044     PUSHs(sv);
3045     RETURN;
3046 }
3047
3048 PP(pp_unshift)
3049 {
3050     djSP; dMARK; dORIGMARK; dTARGET;
3051     register AV *ary = (AV*)*++MARK;
3052     register SV *sv;
3053     register I32 i = 0;
3054     MAGIC *mg;
3055
3056     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3057         *MARK-- = SvTIED_obj((SV*)ary, mg);
3058         PUSHMARK(MARK);
3059         PUTBACK;
3060         ENTER;
3061         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3062         LEAVE;
3063         SPAGAIN;
3064     }
3065     else {
3066         av_unshift(ary, SP - MARK);
3067         while (MARK < SP) {
3068             sv = NEWSV(27, 0);
3069             sv_setsv(sv, *++MARK);
3070             (void)av_store(ary, i++, sv);
3071         }
3072     }
3073     SP = ORIGMARK;
3074     PUSHi( AvFILL(ary) + 1 );
3075     RETURN;
3076 }
3077
3078 PP(pp_reverse)
3079 {
3080     djSP; dMARK;
3081     register SV *tmp;
3082     SV **oldsp = SP;
3083
3084     if (GIMME == G_ARRAY) {
3085         MARK++;
3086         while (MARK < SP) {
3087             tmp = *MARK;
3088             *MARK++ = *SP;
3089             *SP-- = tmp;
3090         }
3091         SP = oldsp;
3092     }
3093     else {
3094         register char *up;
3095         register char *down;
3096         register I32 tmp;
3097         dTARGET;
3098         STRLEN len;
3099
3100         if (SP - MARK > 1)
3101             do_join(TARG, &PL_sv_no, MARK, SP);
3102         else
3103             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3104         up = SvPV_force(TARG, len);
3105         if (len > 1) {
3106             if (IN_UTF8) {      /* first reverse each character */
3107                 U8* s = (U8*)SvPVX(TARG);
3108                 U8* send = (U8*)(s + len);
3109                 while (s < send) {
3110                     if (*s < 0x80) {
3111                         s++;
3112                         continue;
3113                     }
3114                     else {
3115                         up = (char*)s;
3116                         s += UTF8SKIP(s);
3117                         down = (char*)(s - 1);
3118                         if (s > send || !((*down & 0xc0) == 0x80)) {
3119                             warn("Malformed UTF-8 character");
3120                             break;
3121                         }
3122                         while (down > up) {
3123                             tmp = *up;
3124                             *up++ = *down;
3125                             *down-- = tmp;
3126                         }
3127                     }
3128                 }
3129                 up = SvPVX(TARG);
3130             }
3131             down = SvPVX(TARG) + len - 1;
3132             while (down > up) {
3133                 tmp = *up;
3134                 *up++ = *down;
3135                 *down-- = tmp;
3136             }
3137             (void)SvPOK_only(TARG);
3138         }
3139         SP = MARK + 1;
3140         SETTARG;
3141     }
3142     RETURN;
3143 }
3144
3145 STATIC SV      *
3146 mul128(SV *sv, U8 m)
3147 {
3148   STRLEN          len;
3149   char           *s = SvPV(sv, len);
3150   char           *t;
3151   U32             i = 0;
3152
3153   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3154     SV             *tmpNew = newSVpv("0000000000", 10);
3155
3156     sv_catsv(tmpNew, sv);
3157     SvREFCNT_dec(sv);           /* free old sv */
3158     sv = tmpNew;
3159     s = SvPV(sv, len);
3160   }
3161   t = s + len - 1;
3162   while (!*t)                   /* trailing '\0'? */
3163     t--;
3164   while (t > s) {
3165     i = ((*t - '0') << 7) + m;
3166     *(t--) = '0' + (i % 10);
3167     m = i / 10;
3168   }
3169   return (sv);
3170 }
3171
3172 /* Explosives and implosives. */
3173
3174 static const char uuemap[] =
3175     "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3176 static char uudmap[256];        /* Initialised on first use */
3177 #if 'I' == 73 && 'J' == 74
3178 /* On an ASCII/ISO kind of system */
3179 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3180 #else
3181 /*
3182   Some other sort of character set - use memchr() so we don't match
3183   the null byte.
3184  */
3185 #define ISUUCHAR(ch)    (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3186 #endif
3187
3188 PP(pp_unpack)
3189 {
3190     djSP;
3191     dPOPPOPssrl;
3192     SV **oldsp = SP;
3193     I32 gimme = GIMME_V;
3194     SV *sv;
3195     STRLEN llen;
3196     STRLEN rlen;
3197     register char *pat = SvPV(left, llen);
3198     register char *s = SvPV(right, rlen);
3199     char *strend = s + rlen;
3200     char *strbeg = s;
3201     register char *patend = pat + llen;
3202     I32 datumtype;
3203     register I32 len;
3204     register I32 bits;
3205
3206     /* These must not be in registers: */
3207     I16 ashort;
3208     int aint;
3209     I32 along;
3210 #ifdef HAS_QUAD
3211     Quad_t aquad;
3212 #endif
3213     U16 aushort;
3214     unsigned int auint;
3215     U32 aulong;
3216 #ifdef HAS_QUAD
3217     Uquad_t auquad;
3218 #endif
3219     char *aptr;
3220     float afloat;
3221     double adouble;
3222     I32 checksum = 0;
3223     register U32 culong;
3224     double cdouble;
3225     static char* bitcount = 0;
3226     int commas = 0;
3227
3228     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3229         /*SUPPRESS 530*/
3230         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3231         if (strchr("aAbBhHP", *patend) || *pat == '%') {
3232             patend++;
3233             while (isDIGIT(*patend) || *patend == '*')
3234                 patend++;
3235         }
3236         else
3237             patend++;
3238     }
3239     while (pat < patend) {
3240       reparse:
3241         datumtype = *pat++ & 0xFF;
3242         if (isSPACE(datumtype))
3243             continue;
3244         if (pat >= patend)
3245             len = 1;
3246         else if (*pat == '*') {
3247             len = strend - strbeg;      /* long enough */
3248             pat++;
3249         }
3250         else if (isDIGIT(*pat)) {
3251             len = *pat++ - '0';
3252             while (isDIGIT(*pat))
3253                 len = (len * 10) + (*pat++ - '0');
3254         }
3255         else
3256             len = (datumtype != '@');
3257         switch(datumtype) {
3258         default:
3259             croak("Invalid type in unpack: '%c'", (int)datumtype);
3260         case ',': /* grandfather in commas but with a warning */
3261             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3262                 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3263             break;
3264         case '%':
3265             if (len == 1 && pat[-1] != '1')
3266                 len = 16;
3267             checksum = len;
3268             culong = 0;
3269             cdouble = 0;
3270             if (pat < patend)
3271                 goto reparse;
3272             break;
3273         case '@':
3274             if (len > strend - strbeg)
3275                 DIE("@ outside of string");
3276             s = strbeg + len;
3277             break;
3278         case 'X':
3279             if (len > s - strbeg)
3280                 DIE("X outside of string");
3281             s -= len;
3282             break;
3283         case 'x':
3284             if (len > strend - s)
3285                 DIE("x outside of string");
3286             s += len;
3287             break;
3288         case 'A':
3289         case 'a':
3290             if (len > strend - s)
3291                 len = strend - s;
3292             if (checksum)
3293                 goto uchar_checksum;
3294             sv = NEWSV(35, len);
3295             sv_setpvn(sv, s, len);
3296             s += len;
3297             if (datumtype == 'A') {
3298                 aptr = s;       /* borrow register */
3299                 s = SvPVX(sv) + len - 1;
3300                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3301                     s--;
3302                 *++s = '\0';
3303                 SvCUR_set(sv, s - SvPVX(sv));
3304                 s = aptr;       /* unborrow register */
3305             }
3306             XPUSHs(sv_2mortal(sv));
3307             break;
3308         case 'B':
3309         case 'b':
3310             if (pat[-1] == '*' || len > (strend - s) * 8)
3311                 len = (strend - s) * 8;
3312             if (checksum) {
3313                 if (!bitcount) {
3314                     Newz(601, bitcount, 256, char);
3315                     for (bits = 1; bits < 256; bits++) {
3316                         if (bits & 1)   bitcount[bits]++;
3317                         if (bits & 2)   bitcount[bits]++;
3318                         if (bits & 4)   bitcount[bits]++;
3319                         if (bits & 8)   bitcount[bits]++;
3320                         if (bits & 16)  bitcount[bits]++;
3321                         if (bits & 32)  bitcount[bits]++;
3322                         if (bits & 64)  bitcount[bits]++;
3323                         if (bits & 128) bitcount[bits]++;
3324                     }
3325                 }
3326                 while (len >= 8) {
3327                     culong += bitcount[*(unsigned char*)s++];
3328                     len -= 8;
3329                 }
3330                 if (len) {
3331                     bits = *s;
3332                     if (datumtype == 'b') {
3333                         while (len-- > 0) {
3334                             if (bits & 1) culong++;
3335                             bits >>= 1;
3336                         }
3337                     }
3338                     else {
3339                         while (len-- > 0) {
3340                             if (bits & 128) culong++;
3341                             bits <<= 1;
3342                         }
3343                     }
3344                 }
3345                 break;
3346             }
3347             sv = NEWSV(35, len + 1);
3348             SvCUR_set(sv, len);
3349             SvPOK_on(sv);
3350             aptr = pat;                 /* borrow register */
3351             pat = SvPVX(sv);
3352             if (datumtype == 'b') {
3353                 aint = len;
3354                 for (len = 0; len < aint; len++) {
3355                     if (len & 7)                /*SUPPRESS 595*/
3356                         bits >>= 1;
3357                     else
3358                         bits = *s++;
3359                     *pat++ = '0' + (bits & 1);
3360                 }
3361             }
3362             else {
3363                 aint = len;
3364                 for (len = 0; len < aint; len++) {
3365                     if (len & 7)
3366                         bits <<= 1;
3367                     else
3368                         bits = *s++;
3369                     *pat++ = '0' + ((bits & 128) != 0);
3370                 }
3371             }
3372             *pat = '\0';
3373             pat = aptr;                 /* unborrow register */
3374             XPUSHs(sv_2mortal(sv));
3375             break;
3376         case 'H':
3377         case 'h':
3378             if (pat[-1] == '*' || len > (strend - s) * 2)
3379                 len = (strend - s) * 2;
3380             sv = NEWSV(35, len + 1);
3381             SvCUR_set(sv, len);
3382             SvPOK_on(sv);
3383             aptr = pat;                 /* borrow register */
3384             pat = SvPVX(sv);
3385             if (datumtype == 'h') {
3386                 aint = len;
3387                 for (len = 0; len < aint; len++) {
3388                     if (len & 1)
3389                         bits >>= 4;
3390                     else
3391                         bits = *s++;
3392                     *pat++ = PL_hexdigit[bits & 15];
3393                 }
3394             }
3395             else {
3396                 aint = len;
3397                 for (len = 0; len < aint; len++) {
3398                     if (len & 1)
3399                         bits <<= 4;
3400                     else
3401                         bits = *s++;
3402                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3403                 }
3404             }
3405             *pat = '\0';
3406             pat = aptr;                 /* unborrow register */
3407             XPUSHs(sv_2mortal(sv));
3408             break;
3409         case 'c':
3410             if (len > strend - s)
3411                 len = strend - s;
3412             if (checksum) {
3413                 while (len-- > 0) {
3414                     aint = *s++;
3415                     if (aint >= 128)    /* fake up signed chars */
3416                         aint -= 256;
3417                     culong += aint;
3418                 }
3419             }
3420             else {
3421                 EXTEND(SP, len);
3422                 EXTEND_MORTAL(len);
3423                 while (len-- > 0) {
3424                     aint = *s++;
3425                     if (aint >= 128)    /* fake up signed chars */
3426                         aint -= 256;
3427                     sv = NEWSV(36, 0);
3428                     sv_setiv(sv, (IV)aint);
3429                     PUSHs(sv_2mortal(sv));
3430                 }
3431             }
3432             break;
3433         case 'C':
3434             if (len > strend - s)
3435                 len = strend - s;
3436             if (checksum) {
3437               uchar_checksum:
3438                 while (len-- > 0) {
3439                     auint = *s++ & 255;
3440                     culong += auint;
3441                 }
3442             }
3443             else {
3444                 EXTEND(SP, len);
3445                 EXTEND_MORTAL(len);
3446                 while (len-- > 0) {
3447                     auint = *s++ & 255;
3448                     sv = NEWSV(37, 0);
3449                     sv_setiv(sv, (IV)auint);
3450                     PUSHs(sv_2mortal(sv));
3451                 }
3452             }
3453             break;
3454         case 'U':
3455             if (len > strend - s)
3456                 len = strend - s;
3457             if (checksum) {
3458                 while (len-- > 0 && s < strend) {
3459                     auint = utf8_to_uv((U8*)s, &along);
3460                     s += along;
3461                     if (checksum > 32)
3462                         cdouble += (double)auint;
3463                     else
3464                         culong += auint;
3465                 }
3466             }
3467             else {
3468                 EXTEND(SP, len);
3469                 EXTEND_MORTAL(len);
3470                 while (len-- > 0 && s < strend) {
3471                     auint = utf8_to_uv((U8*)s, &along);
3472                     s += along;
3473                     sv = NEWSV(37, 0);
3474                     sv_setuv(sv, (UV)auint);
3475                     PUSHs(sv_2mortal(sv));
3476                 }
3477             }
3478             break;
3479         case 's':
3480             along = (strend - s) / SIZE16;
3481             if (len > along)
3482                 len = along;
3483             if (checksum) {
3484                 while (len-- > 0) {
3485                     COPY16(s, &ashort);
3486                     s += SIZE16;
3487                     culong += ashort;
3488                 }
3489             }
3490             else {
3491                 EXTEND(SP, len);
3492                 EXTEND_MORTAL(len);
3493                 while (len-- > 0) {
3494                     COPY16(s, &ashort);
3495                     s += SIZE16;
3496                     sv = NEWSV(38, 0);
3497                     sv_setiv(sv, (IV)ashort);
3498                     PUSHs(sv_2mortal(sv));
3499                 }
3500             }
3501             break;
3502         case 'v':
3503         case 'n':
3504         case 'S':
3505             along = (strend - s) / SIZE16;
3506             if (len > along)
3507                 len = along;
3508             if (checksum) {
3509                 while (len-- > 0) {
3510                     COPY16(s, &aushort);
3511                     s += SIZE16;
3512 #ifdef HAS_NTOHS
3513                     if (datumtype == 'n')
3514                         aushort = PerlSock_ntohs(aushort);
3515 #endif
3516 #ifdef HAS_VTOHS
3517                     if (datumtype == 'v')
3518                         aushort = vtohs(aushort);
3519 #endif
3520                     culong += aushort;
3521                 }
3522             }
3523             else {
3524                 EXTEND(SP, len);
3525                 EXTEND_MORTAL(len);
3526                 while (len-- > 0) {
3527                     COPY16(s, &aushort);
3528                     s += SIZE16;
3529                     sv = NEWSV(39, 0);
3530 #ifdef HAS_NTOHS
3531                     if (datumtype == 'n')
3532                         aushort = PerlSock_ntohs(aushort);
3533 #endif
3534 #ifdef HAS_VTOHS
3535                     if (datumtype == 'v')
3536                         aushort = vtohs(aushort);
3537 #endif
3538                     sv_setiv(sv, (IV)aushort);
3539                     PUSHs(sv_2mortal(sv));
3540                 }
3541             }
3542             break;
3543         case 'i':
3544             along = (strend - s) / sizeof(int);
3545             if (len > along)
3546                 len = along;
3547             if (checksum) {
3548                 while (len-- > 0) {
3549                     Copy(s, &aint, 1, int);
3550                     s += sizeof(int);
3551                     if (checksum > 32)
3552                         cdouble += (double)aint;
3553                     else
3554                         culong += aint;
3555                 }
3556             }
3557             else {
3558                 EXTEND(SP, len);
3559                 EXTEND_MORTAL(len);
3560                 while (len-- > 0) {
3561                     Copy(s, &aint, 1, int);
3562                     s += sizeof(int);
3563                     sv = NEWSV(40, 0);
3564 #ifdef __osf__
3565                     /* Without the dummy below unpack("i", pack("i",-1))
3566                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3567                      * cc with optimization turned on */
3568                     (aint) ?
3569                         sv_setiv(sv, (IV)aint) :
3570 #endif
3571                     sv_setiv(sv, (IV)aint);
3572                     PUSHs(sv_2mortal(sv));
3573                 }
3574             }
3575             break;
3576         case 'I':
3577             along = (strend - s) / sizeof(unsigned int);
3578             if (len > along)
3579                 len = along;
3580             if (checksum) {
3581                 while (len-- > 0) {
3582                     Copy(s, &auint, 1, unsigned int);
3583                     s += sizeof(unsigned int);
3584                     if (checksum > 32)
3585                         cdouble += (double)auint;
3586                     else
3587                         culong += auint;
3588                 }
3589             }
3590             else {
3591                 EXTEND(SP, len);
3592                 EXTEND_MORTAL(len);
3593                 while (len-- > 0) {
3594                     Copy(s, &auint, 1, unsigned int);
3595                     s += sizeof(unsigned int);
3596                     sv = NEWSV(41, 0);
3597 #ifdef __osf__
3598                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3599                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3600                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3601                      * with optimization turned on.
3602                      * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3603                      * does not have this problem even with -O4)
3604                      */
3605                     (auint) ?
3606                         sv_setuv(sv, (UV)auint) :
3607 #endif
3608                     sv_setuv(sv, (UV)auint);
3609                     PUSHs(sv_2mortal(sv));
3610                 }
3611             }
3612             break;
3613         case 'l':
3614             along = (strend - s) / SIZE32;
3615             if (len > along)
3616                 len = along;
3617             if (checksum) {
3618                 while (len-- > 0) {
3619                     COPY32(s, &along);
3620                     s += SIZE32;
3621                     if (checksum > 32)
3622                         cdouble += (double)along;
3623                     else
3624                         culong += along;
3625                 }
3626             }
3627             else {
3628                 EXTEND(SP, len);
3629                 EXTEND_MORTAL(len);
3630                 while (len-- > 0) {
3631                     COPY32(s, &along);
3632                     s += SIZE32;
3633                     sv = NEWSV(42, 0);
3634                     sv_setiv(sv, (IV)along);
3635                     PUSHs(sv_2mortal(sv));
3636                 }
3637             }
3638             break;
3639         case 'V':
3640         case 'N':
3641         case 'L':
3642             along = (strend - s) / SIZE32;
3643             if (len > along)
3644                 len = along;
3645             if (checksum) {
3646                 while (len-- > 0) {
3647                     COPY32(s, &aulong);
3648                     s += SIZE32;
3649 #ifdef HAS_NTOHL
3650                     if (datumtype == 'N')
3651                         aulong = PerlSock_ntohl(aulong);
3652 #endif
3653 #ifdef HAS_VTOHL
3654                     if (datumtype == 'V')
3655                         aulong = vtohl(aulong);
3656 #endif
3657                     if (checksum > 32)
3658                         cdouble += (double)aulong;
3659                     else
3660                         culong += aulong;
3661                 }
3662             }
3663             else {
3664                 EXTEND(SP, len);
3665                 EXTEND_MORTAL(len);
3666                 while (len-- > 0) {
3667                     COPY32(s, &aulong);
3668                     s += SIZE32;
3669 #ifdef HAS_NTOHL
3670                     if (datumtype == 'N')
3671                         aulong = PerlSock_ntohl(aulong);
3672 #endif
3673 #ifdef HAS_VTOHL
3674                     if (datumtype == 'V')
3675                         aulong = vtohl(aulong);
3676 #endif
3677                     sv = NEWSV(43, 0);
3678                     sv_setuv(sv, (UV)aulong);
3679                     PUSHs(sv_2mortal(sv));
3680                 }
3681             }
3682             break;
3683         case 'p':
3684             along = (strend - s) / sizeof(char*);
3685             if (len > along)
3686                 len = along;
3687             EXTEND(SP, len);
3688             EXTEND_MORTAL(len);
3689             while (len-- > 0) {
3690                 if (sizeof(char*) > strend - s)
3691                     break;
3692                 else {
3693                     Copy(s, &aptr, 1, char*);
3694                     s += sizeof(char*);
3695                 }
3696                 sv = NEWSV(44, 0);
3697                 if (aptr)
3698                     sv_setpv(sv, aptr);
3699                 PUSHs(sv_2mortal(sv));
3700             }
3701             break;
3702         case 'w':
3703             EXTEND(SP, len);
3704             EXTEND_MORTAL(len);
3705             {
3706                 UV auv = 0;
3707                 U32 bytes = 0;
3708
3709                 while ((len > 0) && (s < strend)) {
3710                     auv = (auv << 7) | (*s & 0x7f);
3711                     if (!(*s++ & 0x80)) {
3712                         bytes = 0;
3713                         sv = NEWSV(40, 0);
3714                         sv_setuv(sv, auv);
3715                         PUSHs(sv_2mortal(sv));
3716                         len--;
3717                         auv = 0;
3718                     }
3719                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3720                         char *t;
3721                         STRLEN n_a;
3722
3723                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3724                         while (s < strend) {
3725                             sv = mul128(sv, *s & 0x7f);
3726                             if (!(*s++ & 0x80)) {
3727                                 bytes = 0;
3728                                 break;
3729                             }
3730                         }
3731                         t = SvPV(sv, n_a);
3732                         while (*t == '0')
3733                             t++;
3734                         sv_chop(sv, t);
3735                         PUSHs(sv_2mortal(sv));
3736                         len--;
3737                         auv = 0;
3738                     }
3739                 }
3740                 if ((s >= strend) && bytes)
3741                     croak("Unterminated compressed integer");
3742             }
3743             break;
3744         case 'P':
3745             EXTEND(SP, 1);
3746             if (sizeof(char*) > strend - s)
3747                 break;
3748             else {
3749                 Copy(s, &aptr, 1, char*);
3750                 s += sizeof(char*);
3751             }
3752             sv = NEWSV(44, 0);
3753             if (aptr)
3754                 sv_setpvn(sv, aptr, len);
3755             PUSHs(sv_2mortal(sv));
3756             break;
3757 #ifdef HAS_QUAD
3758         case 'q':
3759             along = (strend - s) / sizeof(Quad_t);
3760             if (len > along)
3761                 len = along;
3762             EXTEND(SP, len);
3763             EXTEND_MORTAL(len);
3764             while (len-- > 0) {
3765                 if (s + sizeof(Quad_t) > strend)
3766                     aquad = 0;
3767                 else {
3768                     Copy(s, &aquad, 1, Quad_t);
3769                     s += sizeof(Quad_t);
3770                 }
3771                 sv = NEWSV(42, 0);
3772                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3773                     sv_setiv(sv, (IV)aquad);
3774                 else
3775                     sv_setnv(sv, (double)aquad);
3776                 PUSHs(sv_2mortal(sv));
3777             }
3778             break;
3779         case 'Q':
3780             along = (strend - s) / sizeof(Quad_t);
3781             if (len > along)
3782                 len = along;
3783             EXTEND(SP, len);
3784             EXTEND_MORTAL(len);
3785             while (len-- > 0) {
3786                 if (s + sizeof(Uquad_t) > strend)
3787                     auquad = 0;
3788                 else {
3789                     Copy(s, &auquad, 1, Uquad_t);
3790                     s += sizeof(Uquad_t);
3791                 }
3792                 sv = NEWSV(43, 0);
3793                 if (auquad <= UV_MAX)
3794                     sv_setuv(sv, (UV)auquad);
3795                 else
3796                     sv_setnv(sv, (double)auquad);
3797                 PUSHs(sv_2mortal(sv));
3798             }
3799             break;
3800 #endif
3801         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3802         case 'f':
3803         case 'F':
3804             along = (strend - s) / sizeof(float);
3805             if (len > along)
3806                 len = along;
3807             if (checksum) {
3808                 while (len-- > 0) {
3809                     Copy(s, &afloat, 1, float);
3810                     s += sizeof(float);
3811                     cdouble += afloat;
3812                 }
3813             }
3814             else {
3815                 EXTEND(SP, len);
3816                 EXTEND_MORTAL(len);
3817                 while (len-- > 0) {
3818                     Copy(s, &afloat, 1, float);
3819                     s += sizeof(float);
3820                     sv = NEWSV(47, 0);
3821                     sv_setnv(sv, (double)afloat);
3822                     PUSHs(sv_2mortal(sv));
3823                 }
3824             }
3825             break;
3826         case 'd':
3827         case 'D':
3828             along = (strend - s) / sizeof(double);
3829             if (len > along)
3830                 len = along;
3831             if (checksum) {
3832                 while (len-- > 0) {
3833                     Copy(s, &adouble, 1, double);
3834                     s += sizeof(double);
3835                     cdouble += adouble;
3836                 }
3837             }
3838             else {
3839                 EXTEND(SP, len);
3840                 EXTEND_MORTAL(len);
3841                 while (len-- > 0) {
3842                     Copy(s, &adouble, 1, double);
3843                     s += sizeof(double);
3844                     sv = NEWSV(48, 0);
3845                     sv_setnv(sv, (double)adouble);
3846                     PUSHs(sv_2mortal(sv));
3847                 }
3848             }
3849             break;
3850         case 'u':
3851             /* MKS:
3852              * Initialise the decode mapping.  By using a table driven
3853              * algorithm, the code will be character-set independent
3854              * (and just as fast as doing character arithmetic)
3855              */
3856             if (uudmap['M'] == 0) {
3857                 int i;
3858
3859                 for (i = 0; i < sizeof(uuemap); i += 1)
3860                     uudmap[uuemap[i]] = i;
3861                 /*
3862                  * Because ' ' and '`' map to the same value,
3863                  * we need to decode them both the same.
3864                  */
3865                 uudmap[' '] = 0;
3866             }
3867
3868             along = (strend - s) * 3 / 4;
3869             sv = NEWSV(42, along);
3870             if (along)
3871                 SvPOK_on(sv);
3872             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3873                 I32 a, b, c, d;
3874                 char hunk[4];
3875
3876                 hunk[3] = '\0';
3877                 len = uudmap[*s++] & 077;
3878                 while (len > 0) {
3879                     if (s < strend && ISUUCHAR(*s))
3880                         a = uudmap[*s++] & 077;
3881                     else
3882                         a = 0;
3883                     if (s < strend && ISUUCHAR(*s))
3884                         b = uudmap[*s++] & 077;
3885                     else
3886                         b = 0;
3887                     if (s < strend && ISUUCHAR(*s))
3888                         c = uudmap[*s++] & 077;
3889                     else
3890                         c = 0;
3891                     if (s < strend && ISUUCHAR(*s))
3892                         d = uudmap[*s++] & 077;
3893                     else
3894                         d = 0;
3895                     hunk[0] = (a << 2) | (b >> 4);
3896                     hunk[1] = (b << 4) | (c >> 2);
3897                     hunk[2] = (c << 6) | d;
3898                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3899                     len -= 3;
3900                 }
3901                 if (*s == '\n')
3902                     s++;
3903                 else if (s[1] == '\n')          /* possible checksum byte */
3904                     s += 2;
3905             }
3906             XPUSHs(sv_2mortal(sv));
3907             break;
3908         }
3909         if (checksum) {
3910             sv = NEWSV(42, 0);
3911             if (strchr("fFdD", datumtype) ||
3912               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3913                 double trouble;
3914
3915                 adouble = 1.0;
3916                 while (checksum >= 16) {
3917                     checksum -= 16;
3918                     adouble *= 65536.0;
3919                 }
3920                 while (checksum >= 4) {
3921                     checksum -= 4;
3922                     adouble *= 16.0;
3923                 }
3924                 while (checksum--)
3925                     adouble *= 2.0;
3926                 along = (1 << checksum) - 1;
3927                 while (cdouble < 0.0)
3928                     cdouble += adouble;
3929                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3930                 sv_setnv(sv, cdouble);
3931             }
3932             else {
3933                 if (checksum < 32) {
3934                     aulong = (1 << checksum) - 1;
3935                     culong &= aulong;
3936                 }
3937                 sv_setuv(sv, (UV)culong);
3938             }
3939             XPUSHs(sv_2mortal(sv));
3940             checksum = 0;
3941         }
3942     }
3943     if (SP == oldsp && gimme == G_SCALAR)
3944         PUSHs(&PL_sv_undef);
3945     RETURN;
3946 }
3947
3948 STATIC void
3949 doencodes(register SV *sv, register char *s, register I32 len)
3950 {
3951     char hunk[5];
3952
3953     *hunk = uuemap[len];
3954     sv_catpvn(sv, hunk, 1);
3955     hunk[4] = '\0';
3956     while (len > 2) {
3957         hunk[0] = uuemap[(077 & (*s >> 2))];
3958         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3959         hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3960         hunk[3] = uuemap[(077 & (s[2] & 077))];
3961         sv_catpvn(sv, hunk, 4);
3962         s += 3;
3963         len -= 3;
3964     }
3965     if (len > 0) {
3966         char r = (len > 1 ? s[1] : '\0');
3967         hunk[0] = uuemap[(077 & (*s >> 2))];
3968         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3969         hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3970         hunk[3] = uuemap[0];
3971         sv_catpvn(sv, hunk, 4);
3972     }
3973     sv_catpvn(sv, "\n", 1);
3974 }
3975
3976 STATIC SV      *
3977 is_an_int(char *s, STRLEN l)
3978 {
3979   STRLEN         n_a;
3980   SV             *result = newSVpv("", l);
3981   char           *result_c = SvPV(result, n_a); /* convenience */
3982   char           *out = result_c;
3983   bool            skip = 1;
3984   bool            ignore = 0;
3985
3986   while (*s) {
3987     switch (*s) {
3988     case ' ':
3989       break;
3990     case '+':
3991       if (!skip) {
3992         SvREFCNT_dec(result);
3993         return (NULL);
3994       }
3995       break;
3996     case '0':
3997     case '1':
3998     case '2':
3999     case '3':
4000     case '4':
4001     case '5':
4002     case '6':
4003     case '7':
4004     case '8':
4005     case '9':
4006       skip = 0;
4007       if (!ignore) {
4008         *(out++) = *s;
4009       }
4010       break;
4011     case '.':
4012       ignore = 1;
4013       break;
4014     default:
4015       SvREFCNT_dec(result);
4016       return (NULL);
4017     }
4018     s++;
4019   }
4020   *(out++) = '\0';
4021   SvCUR_set(result, out - result_c);
4022   return (result);
4023 }
4024
4025 STATIC int
4026 div128(SV *pnum, bool *done)
4027                                             /* must be '\0' terminated */
4028
4029 {
4030   STRLEN          len;
4031   char           *s = SvPV(pnum, len);
4032   int             m = 0;
4033   int             r = 0;
4034   char           *t = s;
4035
4036   *done = 1;
4037   while (*t) {
4038     int             i;
4039
4040     i = m * 10 + (*t - '0');
4041     m = i & 0x7F;
4042     r = (i >> 7);               /* r < 10 */
4043     if (r) {
4044       *done = 0;
4045     }
4046     *(t++) = '0' + r;
4047   }
4048   *(t++) = '\0';
4049   SvCUR_set(pnum, (STRLEN) (t - s));
4050   return (m);
4051 }
4052
4053
4054 PP(pp_pack)
4055 {
4056     djSP; dMARK; dORIGMARK; dTARGET;
4057     register SV *cat = TARG;
4058     register I32 items;
4059     STRLEN fromlen;
4060     register char *pat = SvPVx(*++MARK, fromlen);
4061     register char *patend = pat + fromlen;
4062     register I32 len;
4063     I32 datumtype;
4064     SV *fromstr;
4065     /*SUPPRESS 442*/
4066     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4067     static char *space10 = "          ";
4068
4069     /* These must not be in registers: */
4070     char achar;
4071     I16 ashort;
4072     int aint;
4073     unsigned int auint;
4074     I32 along;
4075     U32 aulong;
4076 #ifdef HAS_QUAD
4077     Quad_t aquad;
4078     Uquad_t auquad;
4079 #endif
4080     char *aptr;
4081     float afloat;
4082     double adouble;
4083     int commas = 0;
4084
4085     items = SP - MARK;
4086     MARK++;
4087     sv_setpvn(cat, "", 0);
4088     while (pat < patend) {
4089 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4090         datumtype = *pat++ & 0xFF;
4091         if (isSPACE(datumtype))
4092             continue;
4093         if (*pat == '*') {
4094             len = strchr("@Xxu", datumtype) ? 0 : items;
4095             pat++;
4096         }
4097         else if (isDIGIT(*pat)) {
4098             len = *pat++ - '0';
4099             while (isDIGIT(*pat))
4100                 len = (len * 10) + (*pat++ - '0');
4101         }
4102         else
4103             len = 1;
4104         switch(datumtype) {
4105         default:
4106             croak("Invalid type in pack: '%c'", (int)datumtype);
4107         case ',': /* grandfather in commas but with a warning */
4108             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4109                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4110             break;
4111         case '%':
4112             DIE("%% may only be used in unpack");
4113         case '@':
4114             len -= SvCUR(cat);
4115             if (len > 0)
4116                 goto grow;
4117             len = -len;
4118             if (len > 0)
4119                 goto shrink;
4120             break;
4121         case 'X':
4122           shrink:
4123             if (SvCUR(cat) < len)
4124                 DIE("X outside of string");
4125             SvCUR(cat) -= len;
4126             *SvEND(cat) = '\0';
4127             break;
4128         case 'x':
4129           grow:
4130             while (len >= 10) {
4131                 sv_catpvn(cat, null10, 10);
4132                 len -= 10;
4133             }
4134             sv_catpvn(cat, null10, len);
4135             break;
4136         case 'A':
4137         case 'a':
4138             fromstr = NEXTFROM;
4139             aptr = SvPV(fromstr, fromlen);
4140             if (pat[-1] == '*')
4141                 len = fromlen;
4142             if (fromlen > len)
4143                 sv_catpvn(cat, aptr, len);
4144             else {
4145                 sv_catpvn(cat, aptr, fromlen);
4146                 len -= fromlen;
4147                 if (datumtype == 'A') {
4148                     while (len >= 10) {
4149                         sv_catpvn(cat, space10, 10);
4150                         len -= 10;
4151                     }
4152                     sv_catpvn(cat, space10, len);
4153                 }
4154                 else {
4155                     while (len >= 10) {
4156                         sv_catpvn(cat, null10, 10);
4157                         len -= 10;
4158                     }
4159                     sv_catpvn(cat, null10, len);
4160                 }
4161             }
4162             break;
4163         case 'B':
4164         case 'b':
4165             {
4166                 char *savepat = pat;
4167                 I32 saveitems;
4168
4169                 fromstr = NEXTFROM;
4170                 saveitems = items;
4171                 aptr = SvPV(fromstr, fromlen);
4172                 if (pat[-1] == '*')
4173                     len = fromlen;
4174                 pat = aptr;
4175                 aint = SvCUR(cat);
4176                 SvCUR(cat) += (len+7)/8;
4177                 SvGROW(cat, SvCUR(cat) + 1);
4178                 aptr = SvPVX(cat) + aint;
4179                 if (len > fromlen)
4180                     len = fromlen;
4181                 aint = len;
4182                 items = 0;
4183                 if (datumtype == 'B') {
4184                     for (len = 0; len++ < aint;) {
4185                         items |= *pat++ & 1;
4186                         if (len & 7)
4187                             items <<= 1;
4188                         else {
4189                             *aptr++ = items & 0xff;
4190                             items = 0;
4191                         }
4192                     }
4193                 }
4194                 else {
4195                     for (len = 0; len++ < aint;) {
4196                         if (*pat++ & 1)
4197                             items |= 128;
4198                         if (len & 7)
4199                             items >>= 1;
4200                         else {
4201                             *aptr++ = items & 0xff;
4202                             items = 0;
4203                         }
4204                     }
4205                 }
4206                 if (aint & 7) {
4207                     if (datumtype == 'B')
4208                         items <<= 7 - (aint & 7);
4209                     else
4210                         items >>= 7 - (aint & 7);
4211                     *aptr++ = items & 0xff;
4212                 }
4213                 pat = SvPVX(cat) + SvCUR(cat);
4214                 while (aptr <= pat)
4215                     *aptr++ = '\0';
4216
4217                 pat = savepat;
4218                 items = saveitems;
4219             }
4220             break;
4221         case 'H':
4222         case 'h':
4223             {
4224                 char *savepat = pat;
4225                 I32 saveitems;
4226
4227                 fromstr = NEXTFROM;
4228                 saveitems = items;
4229                 aptr = SvPV(fromstr, fromlen);
4230                 if (pat[-1] == '*')
4231                     len = fromlen;
4232                 pat = aptr;
4233                 aint = SvCUR(cat);
4234                 SvCUR(cat) += (len+1)/2;
4235                 SvGROW(cat, SvCUR(cat) + 1);
4236                 aptr = SvPVX(cat) + aint;
4237                 if (len > fromlen)
4238                     len = fromlen;
4239                 aint = len;
4240                 items = 0;
4241                 if (datumtype == 'H') {
4242                     for (len = 0; len++ < aint;) {
4243                         if (isALPHA(*pat))
4244                             items |= ((*pat++ & 15) + 9) & 15;
4245                         else
4246                             items |= *pat++ & 15;
4247                         if (len & 1)
4248                             items <<= 4;
4249                         else {
4250                             *aptr++ = items & 0xff;
4251                             items = 0;
4252                         }
4253                     }
4254                 }
4255                 else {
4256                     for (len = 0; len++ < aint;) {
4257                         if (isALPHA(*pat))
4258                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4259                         else
4260                             items |= (*pat++ & 15) << 4;
4261                         if (len & 1)
4262                             items >>= 4;
4263                         else {
4264                             *aptr++ = items & 0xff;
4265                             items = 0;
4266                         }
4267                     }
4268                 }
4269                 if (aint & 1)
4270                     *aptr++ = items & 0xff;
4271                 pat = SvPVX(cat) + SvCUR(cat);
4272                 while (aptr <= pat)
4273                     *aptr++ = '\0';
4274
4275                 pat = savepat;
4276                 items = saveitems;
4277             }
4278             break;
4279         case 'C':
4280         case 'c':
4281             while (len-- > 0) {
4282                 fromstr = NEXTFROM;
4283                 aint = SvIV(fromstr);
4284                 achar = aint;
4285                 sv_catpvn(cat, &achar, sizeof(char));
4286             }
4287             break;
4288         case 'U':
4289             while (len-- > 0) {
4290                 fromstr = NEXTFROM;
4291                 auint = SvUV(fromstr);
4292                 SvGROW(cat, SvCUR(cat) + 10);
4293                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4294                                - SvPVX(cat));
4295             }
4296             *SvEND(cat) = '\0';
4297             break;
4298         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4299         case 'f':
4300         case 'F':
4301             while (len-- > 0) {
4302                 fromstr = NEXTFROM;
4303                 afloat = (float)SvNV(fromstr);
4304                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4305             }
4306             break;
4307         case 'd':
4308         case 'D':
4309             while (len-- > 0) {
4310                 fromstr = NEXTFROM;
4311                 adouble = (double)SvNV(fromstr);
4312                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4313             }
4314             break;
4315         case 'n':
4316             while (len-- > 0) {
4317                 fromstr = NEXTFROM;
4318                 ashort = (I16)SvIV(fromstr);
4319 #ifdef HAS_HTONS
4320                 ashort = PerlSock_htons(ashort);
4321 #endif
4322                 CAT16(cat, &ashort);
4323             }
4324             break;
4325         case 'v':
4326             while (len-- > 0) {
4327                 fromstr = NEXTFROM;
4328                 ashort = (I16)SvIV(fromstr);
4329 #ifdef HAS_HTOVS
4330                 ashort = htovs(ashort);
4331 #endif
4332                 CAT16(cat, &ashort);
4333             }
4334             break;
4335         case 'S':
4336         case 's':
4337             while (len-- > 0) {
4338                 fromstr = NEXTFROM;
4339                 ashort = (I16)SvIV(fromstr);
4340                 CAT16(cat, &ashort);
4341             }
4342             break;
4343         case 'I':
4344             while (len-- > 0) {
4345                 fromstr = NEXTFROM;
4346                 auint = SvUV(fromstr);
4347                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4348             }
4349             break;
4350         case 'w':
4351             while (len-- > 0) {
4352                 fromstr = NEXTFROM;
4353                 adouble = floor(SvNV(fromstr));
4354
4355                 if (adouble < 0)
4356                     croak("Cannot compress negative numbers");
4357
4358                 if (
4359 #ifdef BW_BITS
4360                     adouble <= BW_MASK
4361 #else
4362 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4363                     adouble <= UV_MAX_cxux
4364 #else
4365                     adouble <= UV_MAX
4366 #endif
4367 #endif
4368                     )
4369                 {
4370                     char   buf[1 + sizeof(UV)];
4371                     char  *in = buf + sizeof(buf);
4372                     UV     auv = U_V(adouble);;
4373
4374                     do {
4375                         *--in = (auv & 0x7f) | 0x80;
4376                         auv >>= 7;
4377                     } while (auv);
4378                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4379                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4380                 }
4381                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4382                     char           *from, *result, *in;
4383                     SV             *norm;
4384                     STRLEN          len;
4385                     bool            done;
4386
4387                     /* Copy string and check for compliance */
4388                     from = SvPV(fromstr, len);
4389                     if ((norm = is_an_int(from, len)) == NULL)
4390                         croak("can compress only unsigned integer");
4391
4392                     New('w', result, len, char);
4393                     in = result + len;
4394                     done = FALSE;
4395                     while (!done)
4396                         *--in = div128(norm, &done) | 0x80;
4397                     result[len - 1] &= 0x7F; /* clear continue bit */
4398                     sv_catpvn(cat, in, (result + len) - in);
4399                     Safefree(result);
4400                     SvREFCNT_dec(norm); /* free norm */
4401                 }
4402                 else if (SvNOKp(fromstr)) {
4403                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4404                     char  *in = buf + sizeof(buf);
4405
4406                     do {
4407                         double next = floor(adouble / 128);
4408                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4409                         if (--in < buf)  /* this cannot happen ;-) */
4410                             croak ("Cannot compress integer");
4411                         adouble = next;
4412                     } while (adouble > 0);
4413                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4414                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4415                 }
4416                 else
4417                     croak("Cannot compress non integer");
4418             }
4419             break;
4420         case 'i':
4421             while (len-- > 0) {
4422                 fromstr = NEXTFROM;
4423                 aint = SvIV(fromstr);
4424                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4425             }
4426             break;
4427         case 'N':
4428             while (len-- > 0) {
4429                 fromstr = NEXTFROM;
4430                 aulong = SvUV(fromstr);
4431 #ifdef HAS_HTONL
4432                 aulong = PerlSock_htonl(aulong);
4433 #endif
4434                 CAT32(cat, &aulong);
4435             }
4436             break;
4437         case 'V':
4438             while (len-- > 0) {
4439                 fromstr = NEXTFROM;
4440                 aulong = SvUV(fromstr);
4441 #ifdef HAS_HTOVL
4442                 aulong = htovl(aulong);
4443 #endif
4444                 CAT32(cat, &aulong);
4445             }
4446             break;
4447         case 'L':
4448             while (len-- > 0) {
4449                 fromstr = NEXTFROM;
4450                 aulong = SvUV(fromstr);
4451                 CAT32(cat, &aulong);
4452             }
4453             break;
4454         case 'l':
4455             while (len-- > 0) {
4456                 fromstr = NEXTFROM;
4457                 along = SvIV(fromstr);
4458                 CAT32(cat, &along);
4459             }
4460             break;
4461 #ifdef HAS_QUAD
4462         case 'Q':
4463             while (len-- > 0) {
4464                 fromstr = NEXTFROM;
4465                 auquad = (Uquad_t)SvIV(fromstr);
4466                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4467             }
4468             break;
4469         case 'q':
4470             while (len-- > 0) {
4471                 fromstr = NEXTFROM;
4472                 aquad = (Quad_t)SvIV(fromstr);
4473                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4474             }
4475             break;
4476 #endif /* HAS_QUAD */
4477         case 'P':
4478             len = 1;            /* assume SV is correct length */
4479             /* FALL THROUGH */
4480         case 'p':
4481             while (len-- > 0) {
4482                 fromstr = NEXTFROM;
4483                 if (fromstr == &PL_sv_undef)
4484                     aptr = NULL;
4485                 else {
4486                     STRLEN n_a;
4487                     /* XXX better yet, could spirit away the string to
4488                      * a safe spot and hang on to it until the result
4489                      * of pack() (and all copies of the result) are
4490                      * gone.
4491                      */
4492                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4493                         warner(WARN_UNSAFE,
4494                                 "Attempt to pack pointer to temporary value");
4495                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4496                         aptr = SvPV(fromstr,n_a);
4497                     else
4498                         aptr = SvPV_force(fromstr,n_a);
4499                 }
4500                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4501             }
4502             break;
4503         case 'u':
4504             fromstr = NEXTFROM;
4505             aptr = SvPV(fromstr, fromlen);
4506             SvGROW(cat, fromlen * 4 / 3);
4507             if (len <= 1)
4508                 len = 45;
4509             else
4510                 len = len / 3 * 3;
4511             while (fromlen > 0) {
4512                 I32 todo;
4513
4514                 if (fromlen > len)
4515                     todo = len;
4516                 else
4517                     todo = fromlen;
4518                 doencodes(cat, aptr, todo);
4519                 fromlen -= todo;
4520                 aptr += todo;
4521             }
4522             break;
4523         }
4524     }
4525     SvSETMAGIC(cat);
4526     SP = ORIGMARK;
4527     PUSHs(cat);
4528     RETURN;
4529 }
4530 #undef NEXTFROM
4531
4532
4533 PP(pp_split)
4534 {
4535     djSP; dTARG;
4536     AV *ary;
4537     register I32 limit = POPi;                  /* note, negative is forever */
4538     SV *sv = POPs;
4539     STRLEN len;
4540     register char *s = SvPV(sv, len);
4541     char *strend = s + len;
4542     register PMOP *pm;
4543     register REGEXP *rx;
4544     register SV *dstr;
4545     register char *m;
4546     I32 iters = 0;
4547     I32 maxiters = (strend - s) + 10;
4548     I32 i;
4549     char *orig;
4550     I32 origlimit = limit;
4551     I32 realarray = 0;
4552     I32 base;
4553     AV *oldstack = PL_curstack;
4554     I32 gimme = GIMME_V;
4555     I32 oldsave = PL_savestack_ix;
4556     I32 make_mortal = 1;
4557     MAGIC *mg = (MAGIC *) NULL;
4558
4559 #ifdef DEBUGGING
4560     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4561 #else
4562     pm = (PMOP*)POPs;
4563 #endif
4564     if (!pm || !s)
4565         DIE("panic: do_split");
4566     rx = pm->op_pmregexp;
4567
4568     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4569              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4570
4571     if (pm->op_pmreplroot)
4572         ary = GvAVn((GV*)pm->op_pmreplroot);
4573     else if (gimme != G_ARRAY)
4574 #ifdef USE_THREADS
4575         ary = (AV*)PL_curpad[0];
4576 #else
4577         ary = GvAVn(PL_defgv);
4578 #endif /* USE_THREADS */
4579     else
4580         ary = Nullav;
4581     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4582         realarray = 1;
4583         PUTBACK;
4584         av_extend(ary,0);
4585         av_clear(ary);
4586         SPAGAIN;
4587         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4588             PUSHMARK(SP);
4589             XPUSHs(SvTIED_obj((SV*)ary, mg));
4590         }
4591         else {
4592             if (!AvREAL(ary)) {
4593                 AvREAL_on(ary);
4594                 for (i = AvFILLp(ary); i >= 0; i--)
4595                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4596             }
4597             /* temporarily switch stacks */
4598             SWITCHSTACK(PL_curstack, ary);
4599             make_mortal = 0;
4600         }
4601     }
4602     base = SP - PL_stack_base;
4603     orig = s;
4604     if (pm->op_pmflags & PMf_SKIPWHITE) {
4605         if (pm->op_pmflags & PMf_LOCALE) {
4606             while (isSPACE_LC(*s))
4607                 s++;
4608         }
4609         else {
4610             while (isSPACE(*s))
4611                 s++;
4612         }
4613     }
4614     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4615         SAVEINT(PL_multiline);
4616         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4617     }
4618
4619     if (!limit)
4620         limit = maxiters + 2;
4621     if (pm->op_pmflags & PMf_WHITE) {
4622         while (--limit) {
4623             m = s;
4624             while (m < strend &&
4625                    !((pm->op_pmflags & PMf_LOCALE)
4626                      ? isSPACE_LC(*m) : isSPACE(*m)))
4627                 ++m;
4628             if (m >= strend)
4629                 break;
4630
4631             dstr = NEWSV(30, m-s);
4632             sv_setpvn(dstr, s, m-s);
4633             if (make_mortal)
4634                 sv_2mortal(dstr);
4635             XPUSHs(dstr);
4636
4637             s = m + 1;
4638             while (s < strend &&
4639                    ((pm->op_pmflags & PMf_LOCALE)
4640                     ? isSPACE_LC(*s) : isSPACE(*s)))
4641                 ++s;
4642         }
4643     }
4644     else if (strEQ("^", rx->precomp)) {
4645         while (--limit) {
4646             /*SUPPRESS 530*/
4647             for (m = s; m < strend && *m != '\n'; m++) ;
4648             m++;
4649             if (m >= strend)
4650                 break;
4651             dstr = NEWSV(30, m-s);
4652             sv_setpvn(dstr, s, m-s);
4653             if (make_mortal)
4654                 sv_2mortal(dstr);
4655             XPUSHs(dstr);
4656             s = m;
4657         }
4658     }
4659     else if (rx->check_substr && !rx->nparens
4660              && (rx->reganch & ROPT_CHECK_ALL)
4661              && !(rx->reganch & ROPT_ANCH)) {
4662         i = SvCUR(rx->check_substr);
4663         if (i == 1 && !SvTAIL(rx->check_substr)) {
4664             i = *SvPVX(rx->check_substr);
4665             while (--limit) {
4666                 /*SUPPRESS 530*/
4667                 for (m = s; m < strend && *m != i; m++) ;
4668                 if (m >= strend)
4669                     break;
4670                 dstr = NEWSV(30, m-s);
4671                 sv_setpvn(dstr, s, m-s);
4672                 if (make_mortal)
4673                     sv_2mortal(dstr);
4674                 XPUSHs(dstr);
4675                 s = m + 1;
4676             }
4677         }
4678         else {
4679 #ifndef lint
4680             while (s < strend && --limit &&
4681               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4682                     rx->check_substr, 0)) )
4683 #endif
4684             {
4685                 dstr = NEWSV(31, m-s);
4686                 sv_setpvn(dstr, s, m-s);
4687                 if (make_mortal)
4688                     sv_2mortal(dstr);
4689                 XPUSHs(dstr);
4690                 s = m + i;
4691             }
4692         }
4693     }
4694     else {
4695         maxiters += (strend - s) * rx->nparens;
4696         while (s < strend && --limit &&
4697                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4698         {
4699             TAINT_IF(RX_MATCH_TAINTED(rx));
4700             if (rx->subbase
4701               && rx->subbase != orig) {
4702                 m = s;
4703                 s = orig;
4704                 orig = rx->subbase;
4705                 s = orig + (m - s);
4706                 strend = s + (strend - m);
4707             }
4708             m = rx->startp[0];
4709             dstr = NEWSV(32, m-s);
4710             sv_setpvn(dstr, s, m-s);
4711             if (make_mortal)
4712                 sv_2mortal(dstr);
4713             XPUSHs(dstr);
4714             if (rx->nparens) {
4715                 for (i = 1; i <= rx->nparens; i++) {
4716                     s = rx->startp[i];
4717                     m = rx->endp[i];
4718                     if (m && s) {
4719                         dstr = NEWSV(33, m-s);
4720                         sv_setpvn(dstr, s, m-s);
4721                     }
4722                     else
4723                         dstr = NEWSV(33, 0);
4724                     if (make_mortal)
4725                         sv_2mortal(dstr);
4726                     XPUSHs(dstr);
4727                 }
4728             }
4729             s = rx->endp[0];
4730         }
4731     }
4732
4733     LEAVE_SCOPE(oldsave);
4734     iters = (SP - PL_stack_base) - base;
4735     if (iters > maxiters)
4736         DIE("Split loop");
4737
4738     /* keep field after final delim? */
4739     if (s < strend || (iters && origlimit)) {
4740         dstr = NEWSV(34, strend-s);
4741         sv_setpvn(dstr, s, strend-s);
4742         if (make_mortal)
4743             sv_2mortal(dstr);
4744         XPUSHs(dstr);
4745         iters++;
4746     }
4747     else if (!origlimit) {
4748         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4749             iters--, SP--;
4750     }
4751
4752     if (realarray) {
4753         if (!mg) {
4754             SWITCHSTACK(ary, oldstack);
4755             if (SvSMAGICAL(ary)) {
4756                 PUTBACK;
4757                 mg_set((SV*)ary);
4758                 SPAGAIN;
4759             }
4760             if (gimme == G_ARRAY) {
4761                 EXTEND(SP, iters);
4762                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4763                 SP += iters;
4764                 RETURN;
4765             }
4766         }
4767         else {
4768             PUTBACK;
4769             ENTER;
4770             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4771             LEAVE;
4772             SPAGAIN;
4773             if (gimme == G_ARRAY) {
4774                 /* EXTEND should not be needed - we just popped them */
4775                 EXTEND(SP, iters);
4776                 for (i=0; i < iters; i++) {
4777                     SV **svp = av_fetch(ary, i, FALSE);
4778                     PUSHs((svp) ? *svp : &PL_sv_undef);
4779                 }
4780                 RETURN;
4781             }
4782         }
4783     }
4784     else {
4785         if (gimme == G_ARRAY)
4786             RETURN;
4787     }
4788     if (iters || !pm->op_pmreplroot) {
4789         GETTARGET;
4790         PUSHi(iters);
4791         RETURN;
4792     }
4793     RETPUSHUNDEF;
4794 }
4795
4796 #ifdef USE_THREADS
4797 void
4798 unlock_condpair(void *svv)
4799 {
4800     dTHR;
4801     MAGIC *mg = mg_find((SV*)svv, 'm');
4802
4803     if (!mg)
4804         croak("panic: unlock_condpair unlocking non-mutex");
4805     MUTEX_LOCK(MgMUTEXP(mg));
4806     if (MgOWNER(mg) != thr)
4807         croak("panic: unlock_condpair unlocking mutex that we don't own");
4808     MgOWNER(mg) = 0;
4809     COND_SIGNAL(MgOWNERCONDP(mg));
4810     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4811                           (unsigned long)thr, (unsigned long)svv);)
4812     MUTEX_UNLOCK(MgMUTEXP(mg));
4813 }
4814 #endif /* USE_THREADS */
4815
4816 PP(pp_lock)
4817 {
4818     djSP;
4819     dTOPss;
4820     SV *retsv = sv;
4821 #ifdef USE_THREADS
4822     MAGIC *mg;
4823
4824     if (SvROK(sv))
4825         sv = SvRV(sv);
4826
4827     mg = condpair_magic(sv);
4828     MUTEX_LOCK(MgMUTEXP(mg));
4829     if (MgOWNER(mg) == thr)
4830         MUTEX_UNLOCK(MgMUTEXP(mg));
4831     else {
4832         while (MgOWNER(mg))
4833             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4834         MgOWNER(mg) = thr;
4835         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4836                               (unsigned long)thr, (unsigned long)sv);)
4837         MUTEX_UNLOCK(MgMUTEXP(mg));
4838         save_destructor(unlock_condpair, sv);
4839     }
4840 #endif /* USE_THREADS */
4841     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4842         || SvTYPE(retsv) == SVt_PVCV) {
4843         retsv = refto(retsv);
4844     }
4845     SETs(retsv);
4846     RETURN;
4847 }
4848
4849 PP(pp_threadsv)
4850 {
4851     djSP;
4852 #ifdef USE_THREADS
4853     EXTEND(SP, 1);
4854     if (PL_op->op_private & OPpLVAL_INTRO)
4855         PUSHs(*save_threadsv(PL_op->op_targ));
4856     else
4857         PUSHs(THREADSV(PL_op->op_targ));
4858     RETURN;
4859 #else
4860     DIE("tried to access per-thread data in non-threaded perl");
4861 #endif /* USE_THREADS */
4862 }