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                     sv_setuv(sv, (UV)auint);
3598                     PUSHs(sv_2mortal(sv));
3599                 }
3600             }
3601             break;
3602         case 'l':
3603             along = (strend - s) / SIZE32;
3604             if (len > along)
3605                 len = along;
3606             if (checksum) {
3607                 while (len-- > 0) {
3608                     COPY32(s, &along);
3609                     s += SIZE32;
3610                     if (checksum > 32)
3611                         cdouble += (double)along;
3612                     else
3613                         culong += along;
3614                 }
3615             }
3616             else {
3617                 EXTEND(SP, len);
3618                 EXTEND_MORTAL(len);
3619                 while (len-- > 0) {
3620                     COPY32(s, &along);
3621                     s += SIZE32;
3622                     sv = NEWSV(42, 0);
3623                     sv_setiv(sv, (IV)along);
3624                     PUSHs(sv_2mortal(sv));
3625                 }
3626             }
3627             break;
3628         case 'V':
3629         case 'N':
3630         case 'L':
3631             along = (strend - s) / SIZE32;
3632             if (len > along)
3633                 len = along;
3634             if (checksum) {
3635                 while (len-- > 0) {
3636                     COPY32(s, &aulong);
3637                     s += SIZE32;
3638 #ifdef HAS_NTOHL
3639                     if (datumtype == 'N')
3640                         aulong = PerlSock_ntohl(aulong);
3641 #endif
3642 #ifdef HAS_VTOHL
3643                     if (datumtype == 'V')
3644                         aulong = vtohl(aulong);
3645 #endif
3646                     if (checksum > 32)
3647                         cdouble += (double)aulong;
3648                     else
3649                         culong += aulong;
3650                 }
3651             }
3652             else {
3653                 EXTEND(SP, len);
3654                 EXTEND_MORTAL(len);
3655                 while (len-- > 0) {
3656                     COPY32(s, &aulong);
3657                     s += SIZE32;
3658 #ifdef HAS_NTOHL
3659                     if (datumtype == 'N')
3660                         aulong = PerlSock_ntohl(aulong);
3661 #endif
3662 #ifdef HAS_VTOHL
3663                     if (datumtype == 'V')
3664                         aulong = vtohl(aulong);
3665 #endif
3666                     sv = NEWSV(43, 0);
3667                     sv_setuv(sv, (UV)aulong);
3668                     PUSHs(sv_2mortal(sv));
3669                 }
3670             }
3671             break;
3672         case 'p':
3673             along = (strend - s) / sizeof(char*);
3674             if (len > along)
3675                 len = along;
3676             EXTEND(SP, len);
3677             EXTEND_MORTAL(len);
3678             while (len-- > 0) {
3679                 if (sizeof(char*) > strend - s)
3680                     break;
3681                 else {
3682                     Copy(s, &aptr, 1, char*);
3683                     s += sizeof(char*);
3684                 }
3685                 sv = NEWSV(44, 0);
3686                 if (aptr)
3687                     sv_setpv(sv, aptr);
3688                 PUSHs(sv_2mortal(sv));
3689             }
3690             break;
3691         case 'w':
3692             EXTEND(SP, len);
3693             EXTEND_MORTAL(len);
3694             {
3695                 UV auv = 0;
3696                 U32 bytes = 0;
3697
3698                 while ((len > 0) && (s < strend)) {
3699                     auv = (auv << 7) | (*s & 0x7f);
3700                     if (!(*s++ & 0x80)) {
3701                         bytes = 0;
3702                         sv = NEWSV(40, 0);
3703                         sv_setuv(sv, auv);
3704                         PUSHs(sv_2mortal(sv));
3705                         len--;
3706                         auv = 0;
3707                     }
3708                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3709                         char *t;
3710                         STRLEN n_a;
3711
3712                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3713                         while (s < strend) {
3714                             sv = mul128(sv, *s & 0x7f);
3715                             if (!(*s++ & 0x80)) {
3716                                 bytes = 0;
3717                                 break;
3718                             }
3719                         }
3720                         t = SvPV(sv, n_a);
3721                         while (*t == '0')
3722                             t++;
3723                         sv_chop(sv, t);
3724                         PUSHs(sv_2mortal(sv));
3725                         len--;
3726                         auv = 0;
3727                     }
3728                 }
3729                 if ((s >= strend) && bytes)
3730                     croak("Unterminated compressed integer");
3731             }
3732             break;
3733         case 'P':
3734             EXTEND(SP, 1);
3735             if (sizeof(char*) > strend - s)
3736                 break;
3737             else {
3738                 Copy(s, &aptr, 1, char*);
3739                 s += sizeof(char*);
3740             }
3741             sv = NEWSV(44, 0);
3742             if (aptr)
3743                 sv_setpvn(sv, aptr, len);
3744             PUSHs(sv_2mortal(sv));
3745             break;
3746 #ifdef HAS_QUAD
3747         case 'q':
3748             along = (strend - s) / sizeof(Quad_t);
3749             if (len > along)
3750                 len = along;
3751             EXTEND(SP, len);
3752             EXTEND_MORTAL(len);
3753             while (len-- > 0) {
3754                 if (s + sizeof(Quad_t) > strend)
3755                     aquad = 0;
3756                 else {
3757                     Copy(s, &aquad, 1, Quad_t);
3758                     s += sizeof(Quad_t);
3759                 }
3760                 sv = NEWSV(42, 0);
3761                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3762                     sv_setiv(sv, (IV)aquad);
3763                 else
3764                     sv_setnv(sv, (double)aquad);
3765                 PUSHs(sv_2mortal(sv));
3766             }
3767             break;
3768         case 'Q':
3769             along = (strend - s) / sizeof(Quad_t);
3770             if (len > along)
3771                 len = along;
3772             EXTEND(SP, len);
3773             EXTEND_MORTAL(len);
3774             while (len-- > 0) {
3775                 if (s + sizeof(Uquad_t) > strend)
3776                     auquad = 0;
3777                 else {
3778                     Copy(s, &auquad, 1, Uquad_t);
3779                     s += sizeof(Uquad_t);
3780                 }
3781                 sv = NEWSV(43, 0);
3782                 if (auquad <= UV_MAX)
3783                     sv_setuv(sv, (UV)auquad);
3784                 else
3785                     sv_setnv(sv, (double)auquad);
3786                 PUSHs(sv_2mortal(sv));
3787             }
3788             break;
3789 #endif
3790         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3791         case 'f':
3792         case 'F':
3793             along = (strend - s) / sizeof(float);
3794             if (len > along)
3795                 len = along;
3796             if (checksum) {
3797                 while (len-- > 0) {
3798                     Copy(s, &afloat, 1, float);
3799                     s += sizeof(float);
3800                     cdouble += afloat;
3801                 }
3802             }
3803             else {
3804                 EXTEND(SP, len);
3805                 EXTEND_MORTAL(len);
3806                 while (len-- > 0) {
3807                     Copy(s, &afloat, 1, float);
3808                     s += sizeof(float);
3809                     sv = NEWSV(47, 0);
3810                     sv_setnv(sv, (double)afloat);
3811                     PUSHs(sv_2mortal(sv));
3812                 }
3813             }
3814             break;
3815         case 'd':
3816         case 'D':
3817             along = (strend - s) / sizeof(double);
3818             if (len > along)
3819                 len = along;
3820             if (checksum) {
3821                 while (len-- > 0) {
3822                     Copy(s, &adouble, 1, double);
3823                     s += sizeof(double);
3824                     cdouble += adouble;
3825                 }
3826             }
3827             else {
3828                 EXTEND(SP, len);
3829                 EXTEND_MORTAL(len);
3830                 while (len-- > 0) {
3831                     Copy(s, &adouble, 1, double);
3832                     s += sizeof(double);
3833                     sv = NEWSV(48, 0);
3834                     sv_setnv(sv, (double)adouble);
3835                     PUSHs(sv_2mortal(sv));
3836                 }
3837             }
3838             break;
3839         case 'u':
3840             /* MKS:
3841              * Initialise the decode mapping.  By using a table driven
3842              * algorithm, the code will be character-set independent
3843              * (and just as fast as doing character arithmetic)
3844              */
3845             if (uudmap['M'] == 0) {
3846                 int i;
3847
3848                 for (i = 0; i < sizeof(uuemap); i += 1)
3849                     uudmap[uuemap[i]] = i;
3850                 /*
3851                  * Because ' ' and '`' map to the same value,
3852                  * we need to decode them both the same.
3853                  */
3854                 uudmap[' '] = 0;
3855             }
3856
3857             along = (strend - s) * 3 / 4;
3858             sv = NEWSV(42, along);
3859             if (along)
3860                 SvPOK_on(sv);
3861             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3862                 I32 a, b, c, d;
3863                 char hunk[4];
3864
3865                 hunk[3] = '\0';
3866                 len = uudmap[*s++] & 077;
3867                 while (len > 0) {
3868                     if (s < strend && ISUUCHAR(*s))
3869                         a = uudmap[*s++] & 077;
3870                     else
3871                         a = 0;
3872                     if (s < strend && ISUUCHAR(*s))
3873                         b = uudmap[*s++] & 077;
3874                     else
3875                         b = 0;
3876                     if (s < strend && ISUUCHAR(*s))
3877                         c = uudmap[*s++] & 077;
3878                     else
3879                         c = 0;
3880                     if (s < strend && ISUUCHAR(*s))
3881                         d = uudmap[*s++] & 077;
3882                     else
3883                         d = 0;
3884                     hunk[0] = (a << 2) | (b >> 4);
3885                     hunk[1] = (b << 4) | (c >> 2);
3886                     hunk[2] = (c << 6) | d;
3887                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3888                     len -= 3;
3889                 }
3890                 if (*s == '\n')
3891                     s++;
3892                 else if (s[1] == '\n')          /* possible checksum byte */
3893                     s += 2;
3894             }
3895             XPUSHs(sv_2mortal(sv));
3896             break;
3897         }
3898         if (checksum) {
3899             sv = NEWSV(42, 0);
3900             if (strchr("fFdD", datumtype) ||
3901               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3902                 double trouble;
3903
3904                 adouble = 1.0;
3905                 while (checksum >= 16) {
3906                     checksum -= 16;
3907                     adouble *= 65536.0;
3908                 }
3909                 while (checksum >= 4) {
3910                     checksum -= 4;
3911                     adouble *= 16.0;
3912                 }
3913                 while (checksum--)
3914                     adouble *= 2.0;
3915                 along = (1 << checksum) - 1;
3916                 while (cdouble < 0.0)
3917                     cdouble += adouble;
3918                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3919                 sv_setnv(sv, cdouble);
3920             }
3921             else {
3922                 if (checksum < 32) {
3923                     aulong = (1 << checksum) - 1;
3924                     culong &= aulong;
3925                 }
3926                 sv_setuv(sv, (UV)culong);
3927             }
3928             XPUSHs(sv_2mortal(sv));
3929             checksum = 0;
3930         }
3931     }
3932     if (SP == oldsp && gimme == G_SCALAR)
3933         PUSHs(&PL_sv_undef);
3934     RETURN;
3935 }
3936
3937 STATIC void
3938 doencodes(register SV *sv, register char *s, register I32 len)
3939 {
3940     char hunk[5];
3941
3942     *hunk = uuemap[len];
3943     sv_catpvn(sv, hunk, 1);
3944     hunk[4] = '\0';
3945     while (len > 2) {
3946         hunk[0] = uuemap[(077 & (*s >> 2))];
3947         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3948         hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3949         hunk[3] = uuemap[(077 & (s[2] & 077))];
3950         sv_catpvn(sv, hunk, 4);
3951         s += 3;
3952         len -= 3;
3953     }
3954     if (len > 0) {
3955         char r = (len > 1 ? s[1] : '\0');
3956         hunk[0] = uuemap[(077 & (*s >> 2))];
3957         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3958         hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3959         hunk[3] = uuemap[0];
3960         sv_catpvn(sv, hunk, 4);
3961     }
3962     sv_catpvn(sv, "\n", 1);
3963 }
3964
3965 STATIC SV      *
3966 is_an_int(char *s, STRLEN l)
3967 {
3968   STRLEN         n_a;
3969   SV             *result = newSVpv("", l);
3970   char           *result_c = SvPV(result, n_a); /* convenience */
3971   char           *out = result_c;
3972   bool            skip = 1;
3973   bool            ignore = 0;
3974
3975   while (*s) {
3976     switch (*s) {
3977     case ' ':
3978       break;
3979     case '+':
3980       if (!skip) {
3981         SvREFCNT_dec(result);
3982         return (NULL);
3983       }
3984       break;
3985     case '0':
3986     case '1':
3987     case '2':
3988     case '3':
3989     case '4':
3990     case '5':
3991     case '6':
3992     case '7':
3993     case '8':
3994     case '9':
3995       skip = 0;
3996       if (!ignore) {
3997         *(out++) = *s;
3998       }
3999       break;
4000     case '.':
4001       ignore = 1;
4002       break;
4003     default:
4004       SvREFCNT_dec(result);
4005       return (NULL);
4006     }
4007     s++;
4008   }
4009   *(out++) = '\0';
4010   SvCUR_set(result, out - result_c);
4011   return (result);
4012 }
4013
4014 STATIC int
4015 div128(SV *pnum, bool *done)
4016                                             /* must be '\0' terminated */
4017
4018 {
4019   STRLEN          len;
4020   char           *s = SvPV(pnum, len);
4021   int             m = 0;
4022   int             r = 0;
4023   char           *t = s;
4024
4025   *done = 1;
4026   while (*t) {
4027     int             i;
4028
4029     i = m * 10 + (*t - '0');
4030     m = i & 0x7F;
4031     r = (i >> 7);               /* r < 10 */
4032     if (r) {
4033       *done = 0;
4034     }
4035     *(t++) = '0' + r;
4036   }
4037   *(t++) = '\0';
4038   SvCUR_set(pnum, (STRLEN) (t - s));
4039   return (m);
4040 }
4041
4042
4043 PP(pp_pack)
4044 {
4045     djSP; dMARK; dORIGMARK; dTARGET;
4046     register SV *cat = TARG;
4047     register I32 items;
4048     STRLEN fromlen;
4049     register char *pat = SvPVx(*++MARK, fromlen);
4050     register char *patend = pat + fromlen;
4051     register I32 len;
4052     I32 datumtype;
4053     SV *fromstr;
4054     /*SUPPRESS 442*/
4055     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4056     static char *space10 = "          ";
4057
4058     /* These must not be in registers: */
4059     char achar;
4060     I16 ashort;
4061     int aint;
4062     unsigned int auint;
4063     I32 along;
4064     U32 aulong;
4065 #ifdef HAS_QUAD
4066     Quad_t aquad;
4067     Uquad_t auquad;
4068 #endif
4069     char *aptr;
4070     float afloat;
4071     double adouble;
4072     int commas = 0;
4073
4074     items = SP - MARK;
4075     MARK++;
4076     sv_setpvn(cat, "", 0);
4077     while (pat < patend) {
4078 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4079         datumtype = *pat++ & 0xFF;
4080         if (isSPACE(datumtype))
4081             continue;
4082         if (*pat == '*') {
4083             len = strchr("@Xxu", datumtype) ? 0 : items;
4084             pat++;
4085         }
4086         else if (isDIGIT(*pat)) {
4087             len = *pat++ - '0';
4088             while (isDIGIT(*pat))
4089                 len = (len * 10) + (*pat++ - '0');
4090         }
4091         else
4092             len = 1;
4093         switch(datumtype) {
4094         default:
4095             croak("Invalid type in pack: '%c'", (int)datumtype);
4096         case ',': /* grandfather in commas but with a warning */
4097             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4098                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4099             break;
4100         case '%':
4101             DIE("%% may only be used in unpack");
4102         case '@':
4103             len -= SvCUR(cat);
4104             if (len > 0)
4105                 goto grow;
4106             len = -len;
4107             if (len > 0)
4108                 goto shrink;
4109             break;
4110         case 'X':
4111           shrink:
4112             if (SvCUR(cat) < len)
4113                 DIE("X outside of string");
4114             SvCUR(cat) -= len;
4115             *SvEND(cat) = '\0';
4116             break;
4117         case 'x':
4118           grow:
4119             while (len >= 10) {
4120                 sv_catpvn(cat, null10, 10);
4121                 len -= 10;
4122             }
4123             sv_catpvn(cat, null10, len);
4124             break;
4125         case 'A':
4126         case 'a':
4127             fromstr = NEXTFROM;
4128             aptr = SvPV(fromstr, fromlen);
4129             if (pat[-1] == '*')
4130                 len = fromlen;
4131             if (fromlen > len)
4132                 sv_catpvn(cat, aptr, len);
4133             else {
4134                 sv_catpvn(cat, aptr, fromlen);
4135                 len -= fromlen;
4136                 if (datumtype == 'A') {
4137                     while (len >= 10) {
4138                         sv_catpvn(cat, space10, 10);
4139                         len -= 10;
4140                     }
4141                     sv_catpvn(cat, space10, len);
4142                 }
4143                 else {
4144                     while (len >= 10) {
4145                         sv_catpvn(cat, null10, 10);
4146                         len -= 10;
4147                     }
4148                     sv_catpvn(cat, null10, len);
4149                 }
4150             }
4151             break;
4152         case 'B':
4153         case 'b':
4154             {
4155                 char *savepat = pat;
4156                 I32 saveitems;
4157
4158                 fromstr = NEXTFROM;
4159                 saveitems = items;
4160                 aptr = SvPV(fromstr, fromlen);
4161                 if (pat[-1] == '*')
4162                     len = fromlen;
4163                 pat = aptr;
4164                 aint = SvCUR(cat);
4165                 SvCUR(cat) += (len+7)/8;
4166                 SvGROW(cat, SvCUR(cat) + 1);
4167                 aptr = SvPVX(cat) + aint;
4168                 if (len > fromlen)
4169                     len = fromlen;
4170                 aint = len;
4171                 items = 0;
4172                 if (datumtype == 'B') {
4173                     for (len = 0; len++ < aint;) {
4174                         items |= *pat++ & 1;
4175                         if (len & 7)
4176                             items <<= 1;
4177                         else {
4178                             *aptr++ = items & 0xff;
4179                             items = 0;
4180                         }
4181                     }
4182                 }
4183                 else {
4184                     for (len = 0; len++ < aint;) {
4185                         if (*pat++ & 1)
4186                             items |= 128;
4187                         if (len & 7)
4188                             items >>= 1;
4189                         else {
4190                             *aptr++ = items & 0xff;
4191                             items = 0;
4192                         }
4193                     }
4194                 }
4195                 if (aint & 7) {
4196                     if (datumtype == 'B')
4197                         items <<= 7 - (aint & 7);
4198                     else
4199                         items >>= 7 - (aint & 7);
4200                     *aptr++ = items & 0xff;
4201                 }
4202                 pat = SvPVX(cat) + SvCUR(cat);
4203                 while (aptr <= pat)
4204                     *aptr++ = '\0';
4205
4206                 pat = savepat;
4207                 items = saveitems;
4208             }
4209             break;
4210         case 'H':
4211         case 'h':
4212             {
4213                 char *savepat = pat;
4214                 I32 saveitems;
4215
4216                 fromstr = NEXTFROM;
4217                 saveitems = items;
4218                 aptr = SvPV(fromstr, fromlen);
4219                 if (pat[-1] == '*')
4220                     len = fromlen;
4221                 pat = aptr;
4222                 aint = SvCUR(cat);
4223                 SvCUR(cat) += (len+1)/2;
4224                 SvGROW(cat, SvCUR(cat) + 1);
4225                 aptr = SvPVX(cat) + aint;
4226                 if (len > fromlen)
4227                     len = fromlen;
4228                 aint = len;
4229                 items = 0;
4230                 if (datumtype == 'H') {
4231                     for (len = 0; len++ < aint;) {
4232                         if (isALPHA(*pat))
4233                             items |= ((*pat++ & 15) + 9) & 15;
4234                         else
4235                             items |= *pat++ & 15;
4236                         if (len & 1)
4237                             items <<= 4;
4238                         else {
4239                             *aptr++ = items & 0xff;
4240                             items = 0;
4241                         }
4242                     }
4243                 }
4244                 else {
4245                     for (len = 0; len++ < aint;) {
4246                         if (isALPHA(*pat))
4247                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4248                         else
4249                             items |= (*pat++ & 15) << 4;
4250                         if (len & 1)
4251                             items >>= 4;
4252                         else {
4253                             *aptr++ = items & 0xff;
4254                             items = 0;
4255                         }
4256                     }
4257                 }
4258                 if (aint & 1)
4259                     *aptr++ = items & 0xff;
4260                 pat = SvPVX(cat) + SvCUR(cat);
4261                 while (aptr <= pat)
4262                     *aptr++ = '\0';
4263
4264                 pat = savepat;
4265                 items = saveitems;
4266             }
4267             break;
4268         case 'C':
4269         case 'c':
4270             while (len-- > 0) {
4271                 fromstr = NEXTFROM;
4272                 aint = SvIV(fromstr);
4273                 achar = aint;
4274                 sv_catpvn(cat, &achar, sizeof(char));
4275             }
4276             break;
4277         case 'U':
4278             while (len-- > 0) {
4279                 fromstr = NEXTFROM;
4280                 auint = SvUV(fromstr);
4281                 SvGROW(cat, SvCUR(cat) + 10);
4282                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4283                                - SvPVX(cat));
4284             }
4285             *SvEND(cat) = '\0';
4286             break;
4287         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4288         case 'f':
4289         case 'F':
4290             while (len-- > 0) {
4291                 fromstr = NEXTFROM;
4292                 afloat = (float)SvNV(fromstr);
4293                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4294             }
4295             break;
4296         case 'd':
4297         case 'D':
4298             while (len-- > 0) {
4299                 fromstr = NEXTFROM;
4300                 adouble = (double)SvNV(fromstr);
4301                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4302             }
4303             break;
4304         case 'n':
4305             while (len-- > 0) {
4306                 fromstr = NEXTFROM;
4307                 ashort = (I16)SvIV(fromstr);
4308 #ifdef HAS_HTONS
4309                 ashort = PerlSock_htons(ashort);
4310 #endif
4311                 CAT16(cat, &ashort);
4312             }
4313             break;
4314         case 'v':
4315             while (len-- > 0) {
4316                 fromstr = NEXTFROM;
4317                 ashort = (I16)SvIV(fromstr);
4318 #ifdef HAS_HTOVS
4319                 ashort = htovs(ashort);
4320 #endif
4321                 CAT16(cat, &ashort);
4322             }
4323             break;
4324         case 'S':
4325         case 's':
4326             while (len-- > 0) {
4327                 fromstr = NEXTFROM;
4328                 ashort = (I16)SvIV(fromstr);
4329                 CAT16(cat, &ashort);
4330             }
4331             break;
4332         case 'I':
4333             while (len-- > 0) {
4334                 fromstr = NEXTFROM;
4335                 auint = SvUV(fromstr);
4336                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4337             }
4338             break;
4339         case 'w':
4340             while (len-- > 0) {
4341                 fromstr = NEXTFROM;
4342                 adouble = floor(SvNV(fromstr));
4343
4344                 if (adouble < 0)
4345                     croak("Cannot compress negative numbers");
4346
4347                 if (
4348 #ifdef BW_BITS
4349                     adouble <= BW_MASK
4350 #else
4351 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4352                     adouble <= UV_MAX_cxux
4353 #else
4354                     adouble <= UV_MAX
4355 #endif
4356 #endif
4357                     )
4358                 {
4359                     char   buf[1 + sizeof(UV)];
4360                     char  *in = buf + sizeof(buf);
4361                     UV     auv = U_V(adouble);;
4362
4363                     do {
4364                         *--in = (auv & 0x7f) | 0x80;
4365                         auv >>= 7;
4366                     } while (auv);
4367                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4368                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4369                 }
4370                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4371                     char           *from, *result, *in;
4372                     SV             *norm;
4373                     STRLEN          len;
4374                     bool            done;
4375
4376                     /* Copy string and check for compliance */
4377                     from = SvPV(fromstr, len);
4378                     if ((norm = is_an_int(from, len)) == NULL)
4379                         croak("can compress only unsigned integer");
4380
4381                     New('w', result, len, char);
4382                     in = result + len;
4383                     done = FALSE;
4384                     while (!done)
4385                         *--in = div128(norm, &done) | 0x80;
4386                     result[len - 1] &= 0x7F; /* clear continue bit */
4387                     sv_catpvn(cat, in, (result + len) - in);
4388                     Safefree(result);
4389                     SvREFCNT_dec(norm); /* free norm */
4390                 }
4391                 else if (SvNOKp(fromstr)) {
4392                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4393                     char  *in = buf + sizeof(buf);
4394
4395                     do {
4396                         double next = floor(adouble / 128);
4397                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4398                         if (--in < buf)  /* this cannot happen ;-) */
4399                             croak ("Cannot compress integer");
4400                         adouble = next;
4401                     } while (adouble > 0);
4402                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4403                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4404                 }
4405                 else
4406                     croak("Cannot compress non integer");
4407             }
4408             break;
4409         case 'i':
4410             while (len-- > 0) {
4411                 fromstr = NEXTFROM;
4412                 aint = SvIV(fromstr);
4413                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4414             }
4415             break;
4416         case 'N':
4417             while (len-- > 0) {
4418                 fromstr = NEXTFROM;
4419                 aulong = SvUV(fromstr);
4420 #ifdef HAS_HTONL
4421                 aulong = PerlSock_htonl(aulong);
4422 #endif
4423                 CAT32(cat, &aulong);
4424             }
4425             break;
4426         case 'V':
4427             while (len-- > 0) {
4428                 fromstr = NEXTFROM;
4429                 aulong = SvUV(fromstr);
4430 #ifdef HAS_HTOVL
4431                 aulong = htovl(aulong);
4432 #endif
4433                 CAT32(cat, &aulong);
4434             }
4435             break;
4436         case 'L':
4437             while (len-- > 0) {
4438                 fromstr = NEXTFROM;
4439                 aulong = SvUV(fromstr);
4440                 CAT32(cat, &aulong);
4441             }
4442             break;
4443         case 'l':
4444             while (len-- > 0) {
4445                 fromstr = NEXTFROM;
4446                 along = SvIV(fromstr);
4447                 CAT32(cat, &along);
4448             }
4449             break;
4450 #ifdef HAS_QUAD
4451         case 'Q':
4452             while (len-- > 0) {
4453                 fromstr = NEXTFROM;
4454                 auquad = (Uquad_t)SvIV(fromstr);
4455                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4456             }
4457             break;
4458         case 'q':
4459             while (len-- > 0) {
4460                 fromstr = NEXTFROM;
4461                 aquad = (Quad_t)SvIV(fromstr);
4462                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4463             }
4464             break;
4465 #endif /* HAS_QUAD */
4466         case 'P':
4467             len = 1;            /* assume SV is correct length */
4468             /* FALL THROUGH */
4469         case 'p':
4470             while (len-- > 0) {
4471                 fromstr = NEXTFROM;
4472                 if (fromstr == &PL_sv_undef)
4473                     aptr = NULL;
4474                 else {
4475                     STRLEN n_a;
4476                     /* XXX better yet, could spirit away the string to
4477                      * a safe spot and hang on to it until the result
4478                      * of pack() (and all copies of the result) are
4479                      * gone.
4480                      */
4481                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4482                         warner(WARN_UNSAFE,
4483                                 "Attempt to pack pointer to temporary value");
4484                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4485                         aptr = SvPV(fromstr,n_a);
4486                     else
4487                         aptr = SvPV_force(fromstr,n_a);
4488                 }
4489                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4490             }
4491             break;
4492         case 'u':
4493             fromstr = NEXTFROM;
4494             aptr = SvPV(fromstr, fromlen);
4495             SvGROW(cat, fromlen * 4 / 3);
4496             if (len <= 1)
4497                 len = 45;
4498             else
4499                 len = len / 3 * 3;
4500             while (fromlen > 0) {
4501                 I32 todo;
4502
4503                 if (fromlen > len)
4504                     todo = len;
4505                 else
4506                     todo = fromlen;
4507                 doencodes(cat, aptr, todo);
4508                 fromlen -= todo;
4509                 aptr += todo;
4510             }
4511             break;
4512         }
4513     }
4514     SvSETMAGIC(cat);
4515     SP = ORIGMARK;
4516     PUSHs(cat);
4517     RETURN;
4518 }
4519 #undef NEXTFROM
4520
4521
4522 PP(pp_split)
4523 {
4524     djSP; dTARG;
4525     AV *ary;
4526     register I32 limit = POPi;                  /* note, negative is forever */
4527     SV *sv = POPs;
4528     STRLEN len;
4529     register char *s = SvPV(sv, len);
4530     char *strend = s + len;
4531     register PMOP *pm;
4532     register REGEXP *rx;
4533     register SV *dstr;
4534     register char *m;
4535     I32 iters = 0;
4536     I32 maxiters = (strend - s) + 10;
4537     I32 i;
4538     char *orig;
4539     I32 origlimit = limit;
4540     I32 realarray = 0;
4541     I32 base;
4542     AV *oldstack = PL_curstack;
4543     I32 gimme = GIMME_V;
4544     I32 oldsave = PL_savestack_ix;
4545     I32 make_mortal = 1;
4546     MAGIC *mg = (MAGIC *) NULL;
4547
4548 #ifdef DEBUGGING
4549     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4550 #else
4551     pm = (PMOP*)POPs;
4552 #endif
4553     if (!pm || !s)
4554         DIE("panic: do_split");
4555     rx = pm->op_pmregexp;
4556
4557     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4558              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4559
4560     if (pm->op_pmreplroot)
4561         ary = GvAVn((GV*)pm->op_pmreplroot);
4562     else if (gimme != G_ARRAY)
4563 #ifdef USE_THREADS
4564         ary = (AV*)PL_curpad[0];
4565 #else
4566         ary = GvAVn(PL_defgv);
4567 #endif /* USE_THREADS */
4568     else
4569         ary = Nullav;
4570     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4571         realarray = 1;
4572         PUTBACK;
4573         av_extend(ary,0);
4574         av_clear(ary);
4575         SPAGAIN;
4576         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4577             PUSHMARK(SP);
4578             XPUSHs(SvTIED_obj((SV*)ary, mg));
4579         }
4580         else {
4581             if (!AvREAL(ary)) {
4582                 AvREAL_on(ary);
4583                 for (i = AvFILLp(ary); i >= 0; i--)
4584                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4585             }
4586             /* temporarily switch stacks */
4587             SWITCHSTACK(PL_curstack, ary);
4588             make_mortal = 0;
4589         }
4590     }
4591     base = SP - PL_stack_base;
4592     orig = s;
4593     if (pm->op_pmflags & PMf_SKIPWHITE) {
4594         if (pm->op_pmflags & PMf_LOCALE) {
4595             while (isSPACE_LC(*s))
4596                 s++;
4597         }
4598         else {
4599             while (isSPACE(*s))
4600                 s++;
4601         }
4602     }
4603     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4604         SAVEINT(PL_multiline);
4605         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4606     }
4607
4608     if (!limit)
4609         limit = maxiters + 2;
4610     if (pm->op_pmflags & PMf_WHITE) {
4611         while (--limit) {
4612             m = s;
4613             while (m < strend &&
4614                    !((pm->op_pmflags & PMf_LOCALE)
4615                      ? isSPACE_LC(*m) : isSPACE(*m)))
4616                 ++m;
4617             if (m >= strend)
4618                 break;
4619
4620             dstr = NEWSV(30, m-s);
4621             sv_setpvn(dstr, s, m-s);
4622             if (make_mortal)
4623                 sv_2mortal(dstr);
4624             XPUSHs(dstr);
4625
4626             s = m + 1;
4627             while (s < strend &&
4628                    ((pm->op_pmflags & PMf_LOCALE)
4629                     ? isSPACE_LC(*s) : isSPACE(*s)))
4630                 ++s;
4631         }
4632     }
4633     else if (strEQ("^", rx->precomp)) {
4634         while (--limit) {
4635             /*SUPPRESS 530*/
4636             for (m = s; m < strend && *m != '\n'; m++) ;
4637             m++;
4638             if (m >= strend)
4639                 break;
4640             dstr = NEWSV(30, m-s);
4641             sv_setpvn(dstr, s, m-s);
4642             if (make_mortal)
4643                 sv_2mortal(dstr);
4644             XPUSHs(dstr);
4645             s = m;
4646         }
4647     }
4648     else if (rx->check_substr && !rx->nparens
4649              && (rx->reganch & ROPT_CHECK_ALL)
4650              && !(rx->reganch & ROPT_ANCH)) {
4651         i = SvCUR(rx->check_substr);
4652         if (i == 1 && !SvTAIL(rx->check_substr)) {
4653             i = *SvPVX(rx->check_substr);
4654             while (--limit) {
4655                 /*SUPPRESS 530*/
4656                 for (m = s; m < strend && *m != i; m++) ;
4657                 if (m >= strend)
4658                     break;
4659                 dstr = NEWSV(30, m-s);
4660                 sv_setpvn(dstr, s, m-s);
4661                 if (make_mortal)
4662                     sv_2mortal(dstr);
4663                 XPUSHs(dstr);
4664                 s = m + 1;
4665             }
4666         }
4667         else {
4668 #ifndef lint
4669             while (s < strend && --limit &&
4670               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4671                     rx->check_substr, 0)) )
4672 #endif
4673             {
4674                 dstr = NEWSV(31, m-s);
4675                 sv_setpvn(dstr, s, m-s);
4676                 if (make_mortal)
4677                     sv_2mortal(dstr);
4678                 XPUSHs(dstr);
4679                 s = m + i;
4680             }
4681         }
4682     }
4683     else {
4684         maxiters += (strend - s) * rx->nparens;
4685         while (s < strend && --limit &&
4686                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4687         {
4688             TAINT_IF(RX_MATCH_TAINTED(rx));
4689             if (rx->subbase
4690               && rx->subbase != orig) {
4691                 m = s;
4692                 s = orig;
4693                 orig = rx->subbase;
4694                 s = orig + (m - s);
4695                 strend = s + (strend - m);
4696             }
4697             m = rx->startp[0];
4698             dstr = NEWSV(32, m-s);
4699             sv_setpvn(dstr, s, m-s);
4700             if (make_mortal)
4701                 sv_2mortal(dstr);
4702             XPUSHs(dstr);
4703             if (rx->nparens) {
4704                 for (i = 1; i <= rx->nparens; i++) {
4705                     s = rx->startp[i];
4706                     m = rx->endp[i];
4707                     if (m && s) {
4708                         dstr = NEWSV(33, m-s);
4709                         sv_setpvn(dstr, s, m-s);
4710                     }
4711                     else
4712                         dstr = NEWSV(33, 0);
4713                     if (make_mortal)
4714                         sv_2mortal(dstr);
4715                     XPUSHs(dstr);
4716                 }
4717             }
4718             s = rx->endp[0];
4719         }
4720     }
4721
4722     LEAVE_SCOPE(oldsave);
4723     iters = (SP - PL_stack_base) - base;
4724     if (iters > maxiters)
4725         DIE("Split loop");
4726
4727     /* keep field after final delim? */
4728     if (s < strend || (iters && origlimit)) {
4729         dstr = NEWSV(34, strend-s);
4730         sv_setpvn(dstr, s, strend-s);
4731         if (make_mortal)
4732             sv_2mortal(dstr);
4733         XPUSHs(dstr);
4734         iters++;
4735     }
4736     else if (!origlimit) {
4737         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4738             iters--, SP--;
4739     }
4740
4741     if (realarray) {
4742         if (!mg) {
4743             SWITCHSTACK(ary, oldstack);
4744             if (SvSMAGICAL(ary)) {
4745                 PUTBACK;
4746                 mg_set((SV*)ary);
4747                 SPAGAIN;
4748             }
4749             if (gimme == G_ARRAY) {
4750                 EXTEND(SP, iters);
4751                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4752                 SP += iters;
4753                 RETURN;
4754             }
4755         }
4756         else {
4757             PUTBACK;
4758             ENTER;
4759             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4760             LEAVE;
4761             SPAGAIN;
4762             if (gimme == G_ARRAY) {
4763                 /* EXTEND should not be needed - we just popped them */
4764                 EXTEND(SP, iters);
4765                 for (i=0; i < iters; i++) {
4766                     SV **svp = av_fetch(ary, i, FALSE);
4767                     PUSHs((svp) ? *svp : &PL_sv_undef);
4768                 }
4769                 RETURN;
4770             }
4771         }
4772     }
4773     else {
4774         if (gimme == G_ARRAY)
4775             RETURN;
4776     }
4777     if (iters || !pm->op_pmreplroot) {
4778         GETTARGET;
4779         PUSHi(iters);
4780         RETURN;
4781     }
4782     RETPUSHUNDEF;
4783 }
4784
4785 #ifdef USE_THREADS
4786 void
4787 unlock_condpair(void *svv)
4788 {
4789     dTHR;
4790     MAGIC *mg = mg_find((SV*)svv, 'm');
4791
4792     if (!mg)
4793         croak("panic: unlock_condpair unlocking non-mutex");
4794     MUTEX_LOCK(MgMUTEXP(mg));
4795     if (MgOWNER(mg) != thr)
4796         croak("panic: unlock_condpair unlocking mutex that we don't own");
4797     MgOWNER(mg) = 0;
4798     COND_SIGNAL(MgOWNERCONDP(mg));
4799     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4800                           (unsigned long)thr, (unsigned long)svv);)
4801     MUTEX_UNLOCK(MgMUTEXP(mg));
4802 }
4803 #endif /* USE_THREADS */
4804
4805 PP(pp_lock)
4806 {
4807     djSP;
4808     dTOPss;
4809     SV *retsv = sv;
4810 #ifdef USE_THREADS
4811     MAGIC *mg;
4812
4813     if (SvROK(sv))
4814         sv = SvRV(sv);
4815
4816     mg = condpair_magic(sv);
4817     MUTEX_LOCK(MgMUTEXP(mg));
4818     if (MgOWNER(mg) == thr)
4819         MUTEX_UNLOCK(MgMUTEXP(mg));
4820     else {
4821         while (MgOWNER(mg))
4822             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4823         MgOWNER(mg) = thr;
4824         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4825                               (unsigned long)thr, (unsigned long)sv);)
4826         MUTEX_UNLOCK(MgMUTEXP(mg));
4827         save_destructor(unlock_condpair, sv);
4828     }
4829 #endif /* USE_THREADS */
4830     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4831         || SvTYPE(retsv) == SVt_PVCV) {
4832         retsv = refto(retsv);
4833     }
4834     SETs(retsv);
4835     RETURN;
4836 }
4837
4838 PP(pp_threadsv)
4839 {
4840     djSP;
4841 #ifdef USE_THREADS
4842     EXTEND(SP, 1);
4843     if (PL_op->op_private & OPpLVAL_INTRO)
4844         PUSHs(*save_threadsv(PL_op->op_targ));
4845     else
4846         PUSHs(THREADSV(PL_op->op_targ));
4847     RETURN;
4848 #else
4849     DIE("tried to access per-thread data in non-threaded perl");
4850 #endif /* USE_THREADS */
4851 }