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
1826         value = scan_oct(tmps, 99, &argtype);
1827     XPUSHu(value);
1828     RETURN;
1829 }
1830
1831 /* String stuff. */
1832
1833 PP(pp_length)
1834 {
1835     djSP; dTARGET;
1836
1837     if (IN_UTF8) {
1838         SETi( sv_len_utf8(TOPs) );
1839         RETURN;
1840     }
1841
1842     SETi( sv_len(TOPs) );
1843     RETURN;
1844 }
1845
1846 PP(pp_substr)
1847 {
1848     djSP; dTARGET;
1849     SV *sv;
1850     I32 len;
1851     STRLEN curlen;
1852     STRLEN utfcurlen;
1853     I32 pos;
1854     I32 rem;
1855     I32 fail;
1856     I32 lvalue = PL_op->op_flags & OPf_MOD;
1857     char *tmps;
1858     I32 arybase = PL_curcop->cop_arybase;
1859     char *repl = 0;
1860     STRLEN repl_len;
1861
1862     SvTAINTED_off(TARG);                        /* decontaminate */
1863     if (MAXARG > 2) {
1864         if (MAXARG > 3) {
1865             sv = POPs;
1866             repl = SvPV(sv, repl_len);
1867         }
1868         len = POPi;
1869     }
1870     pos = POPi;
1871     sv = POPs;
1872     PUTBACK;
1873     tmps = SvPV(sv, curlen);
1874     if (IN_UTF8) {
1875         utfcurlen = sv_len_utf8(sv);
1876         if (utfcurlen == curlen)
1877             utfcurlen = 0;
1878         else
1879             curlen = utfcurlen;
1880     }
1881     else
1882         utfcurlen = 0;
1883
1884     if (pos >= arybase) {
1885         pos -= arybase;
1886         rem = curlen-pos;
1887         fail = rem;
1888         if (MAXARG > 2) {
1889             if (len < 0) {
1890                 rem += len;
1891                 if (rem < 0)
1892                     rem = 0;
1893             }
1894             else if (rem > len)
1895                      rem = len;
1896         }
1897     }
1898     else {
1899         pos += curlen;
1900         if (MAXARG < 3)
1901             rem = curlen;
1902         else if (len >= 0) {
1903             rem = pos+len;
1904             if (rem > (I32)curlen)
1905                 rem = curlen;
1906         }
1907         else {
1908             rem = curlen+len;
1909             if (rem < pos)
1910                 rem = pos;
1911         }
1912         if (pos < 0)
1913             pos = 0;
1914         fail = rem;
1915         rem -= pos;
1916     }
1917     if (fail < 0) {
1918         if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1919             warner(WARN_SUBSTR, "substr outside of string");
1920         RETPUSHUNDEF;
1921     }
1922     else {
1923         if (utfcurlen)
1924             sv_pos_u2b(sv, &pos, &rem);
1925         tmps += pos;
1926         sv_setpvn(TARG, tmps, rem);
1927         if (lvalue) {                   /* it's an lvalue! */
1928             if (!SvGMAGICAL(sv)) {
1929                 if (SvROK(sv)) {
1930                     STRLEN n_a;
1931                     SvPV_force(sv,n_a);
1932                     if (ckWARN(WARN_SUBSTR))
1933                         warner(WARN_SUBSTR,
1934                                 "Attempt to use reference as lvalue in substr");
1935                 }
1936                 if (SvOK(sv))           /* is it defined ? */
1937                     (void)SvPOK_only(sv);
1938                 else
1939                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1940             }
1941
1942             if (SvTYPE(TARG) < SVt_PVLV) {
1943                 sv_upgrade(TARG, SVt_PVLV);
1944                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1945             }
1946
1947             LvTYPE(TARG) = 'x';
1948             if (LvTARG(TARG) != sv) {
1949                 if (LvTARG(TARG))
1950                     SvREFCNT_dec(LvTARG(TARG));
1951                 LvTARG(TARG) = SvREFCNT_inc(sv);
1952             }
1953             LvTARGOFF(TARG) = pos;
1954             LvTARGLEN(TARG) = rem;
1955         }
1956         else if (repl)
1957             sv_insert(sv, pos, rem, repl, repl_len);
1958     }
1959     SPAGAIN;
1960     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1961     RETURN;
1962 }
1963
1964 PP(pp_vec)
1965 {
1966     djSP; dTARGET;
1967     register I32 size = POPi;
1968     register I32 offset = POPi;
1969     register SV *src = POPs;
1970     I32 lvalue = PL_op->op_flags & OPf_MOD;
1971     STRLEN srclen;
1972     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1973     unsigned long retnum;
1974     I32 len;
1975
1976     SvTAINTED_off(TARG);                        /* decontaminate */
1977     offset *= size;             /* turn into bit offset */
1978     len = (offset + size + 7) / 8;
1979     if (offset < 0 || size < 1)
1980         retnum = 0;
1981     else {
1982         if (lvalue) {                      /* it's an lvalue! */
1983             if (SvTYPE(TARG) < SVt_PVLV) {
1984                 sv_upgrade(TARG, SVt_PVLV);
1985                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1986             }
1987
1988             LvTYPE(TARG) = 'v';
1989             if (LvTARG(TARG) != src) {
1990                 if (LvTARG(TARG))
1991                     SvREFCNT_dec(LvTARG(TARG));
1992                 LvTARG(TARG) = SvREFCNT_inc(src);
1993             }
1994             LvTARGOFF(TARG) = offset;
1995             LvTARGLEN(TARG) = size;
1996         }
1997         if (len > srclen) {
1998             if (size <= 8)
1999                 retnum = 0;
2000             else {
2001                 offset >>= 3;
2002                 if (size == 16) {
2003                     if (offset >= srclen)
2004                         retnum = 0;
2005                     else
2006                         retnum = (unsigned long) s[offset] << 8;
2007                 }
2008                 else if (size == 32) {
2009                     if (offset >= srclen)
2010                         retnum = 0;
2011                     else if (offset + 1 >= srclen)
2012                         retnum = (unsigned long) s[offset] << 24;
2013                     else if (offset + 2 >= srclen)
2014                         retnum = ((unsigned long) s[offset] << 24) +
2015                             ((unsigned long) s[offset + 1] << 16);
2016                     else
2017                         retnum = ((unsigned long) s[offset] << 24) +
2018                             ((unsigned long) s[offset + 1] << 16) +
2019                             (s[offset + 2] << 8);
2020                 }
2021             }
2022         }
2023         else if (size < 8)
2024             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2025         else {
2026             offset >>= 3;
2027             if (size == 8)
2028                 retnum = s[offset];
2029             else if (size == 16)
2030                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2031             else if (size == 32)
2032                 retnum = ((unsigned long) s[offset] << 24) +
2033                         ((unsigned long) s[offset + 1] << 16) +
2034                         (s[offset + 2] << 8) + s[offset+3];
2035         }
2036     }
2037
2038     sv_setuv(TARG, (UV)retnum);
2039     PUSHs(TARG);
2040     RETURN;
2041 }
2042
2043 PP(pp_index)
2044 {
2045     djSP; dTARGET;
2046     SV *big;
2047     SV *little;
2048     I32 offset;
2049     I32 retval;
2050     char *tmps;
2051     char *tmps2;
2052     STRLEN biglen;
2053     I32 arybase = PL_curcop->cop_arybase;
2054
2055     if (MAXARG < 3)
2056         offset = 0;
2057     else
2058         offset = POPi - arybase;
2059     little = POPs;
2060     big = POPs;
2061     tmps = SvPV(big, biglen);
2062     if (IN_UTF8 && offset > 0)
2063         sv_pos_u2b(big, &offset, 0);
2064     if (offset < 0)
2065         offset = 0;
2066     else if (offset > biglen)
2067         offset = biglen;
2068     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2069       (unsigned char*)tmps + biglen, little, 0)))
2070         retval = -1;
2071     else
2072         retval = tmps2 - tmps;
2073     if (IN_UTF8 && retval > 0)
2074         sv_pos_b2u(big, &retval);
2075     PUSHi(retval + arybase);
2076     RETURN;
2077 }
2078
2079 PP(pp_rindex)
2080 {
2081     djSP; dTARGET;
2082     SV *big;
2083     SV *little;
2084     STRLEN blen;
2085     STRLEN llen;
2086     I32 offset;
2087     I32 retval;
2088     char *tmps;
2089     char *tmps2;
2090     I32 arybase = PL_curcop->cop_arybase;
2091
2092     if (MAXARG >= 3)
2093         offset = POPi;
2094     little = POPs;
2095     big = POPs;
2096     tmps2 = SvPV(little, llen);
2097     tmps = SvPV(big, blen);
2098     if (MAXARG < 3)
2099         offset = blen;
2100     else {
2101         if (IN_UTF8 && offset > 0)
2102             sv_pos_u2b(big, &offset, 0);
2103         offset = offset - arybase + llen;
2104     }
2105     if (offset < 0)
2106         offset = 0;
2107     else if (offset > blen)
2108         offset = blen;
2109     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2110                           tmps2, tmps2 + llen)))
2111         retval = -1;
2112     else
2113         retval = tmps2 - tmps;
2114     if (IN_UTF8 && retval > 0)
2115         sv_pos_b2u(big, &retval);
2116     PUSHi(retval + arybase);
2117     RETURN;
2118 }
2119
2120 PP(pp_sprintf)
2121 {
2122     djSP; dMARK; dORIGMARK; dTARGET;
2123 #ifdef USE_LOCALE_NUMERIC
2124     if (PL_op->op_private & OPpLOCALE)
2125         SET_NUMERIC_LOCAL();
2126     else
2127         SET_NUMERIC_STANDARD();
2128 #endif
2129     do_sprintf(TARG, SP-MARK, MARK+1);
2130     TAINT_IF(SvTAINTED(TARG));
2131     SP = ORIGMARK;
2132     PUSHTARG;
2133     RETURN;
2134 }
2135
2136 PP(pp_ord)
2137 {
2138     djSP; dTARGET;
2139     UV value;
2140     STRLEN n_a;
2141     U8 *tmps = (U8*)POPpx;
2142     I32 retlen;
2143
2144     if (IN_UTF8 && (*tmps & 0x80))
2145         value = utf8_to_uv(tmps, &retlen);
2146     else
2147         value = (UV)(*tmps & 255);
2148     XPUSHu(value);
2149     RETURN;
2150 }
2151
2152 PP(pp_chr)
2153 {
2154     djSP; dTARGET;
2155     char *tmps;
2156     U32 value = POPu;
2157
2158     (void)SvUPGRADE(TARG,SVt_PV);
2159
2160     if (IN_UTF8 && value >= 128) {
2161         SvGROW(TARG,8);
2162         tmps = SvPVX(TARG);
2163         tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2164         SvCUR_set(TARG, tmps - SvPVX(TARG));
2165         *tmps = '\0';
2166         (void)SvPOK_only(TARG);
2167         XPUSHs(TARG);
2168         RETURN;
2169     }
2170
2171     SvGROW(TARG,2);
2172     SvCUR_set(TARG, 1);
2173     tmps = SvPVX(TARG);
2174     *tmps++ = value;
2175     *tmps = '\0';
2176     (void)SvPOK_only(TARG);
2177     XPUSHs(TARG);
2178     RETURN;
2179 }
2180
2181 PP(pp_crypt)
2182 {
2183     djSP; dTARGET; dPOPTOPssrl;
2184     STRLEN n_a;
2185 #ifdef HAS_CRYPT
2186     char *tmps = SvPV(left, n_a);
2187 #ifdef FCRYPT
2188     sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2189 #else
2190     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2191 #endif
2192 #else
2193     DIE(
2194       "The crypt() function is unimplemented due to excessive paranoia.");
2195 #endif
2196     SETs(TARG);
2197     RETURN;
2198 }
2199
2200 PP(pp_ucfirst)
2201 {
2202     djSP;
2203     SV *sv = TOPs;
2204     register U8 *s;
2205     STRLEN slen;
2206
2207     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2208         I32 ulen;
2209         U8 tmpbuf[10];
2210         U8 *tend;
2211         UV uv = utf8_to_uv(s, &ulen);
2212
2213         if (PL_op->op_private & OPpLOCALE) {
2214             TAINT;
2215             SvTAINTED_on(sv);
2216             uv = toTITLE_LC_uni(uv);
2217         }
2218         else
2219             uv = toTITLE_utf8(s);
2220
2221         tend = uv_to_utf8(tmpbuf, uv);
2222
2223         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2224             dTARGET;
2225             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2226             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2227             SETs(TARG);
2228         }
2229         else {
2230             s = (U8*)SvPV_force(sv, slen);
2231             Copy(tmpbuf, s, ulen, U8);
2232         }
2233         RETURN;
2234     }
2235
2236     if (!SvPADTMP(sv)) {
2237         dTARGET;
2238         sv_setsv(TARG, sv);
2239         sv = TARG;
2240         SETs(sv);
2241     }
2242     s = (U8*)SvPV_force(sv, slen);
2243     if (*s) {
2244         if (PL_op->op_private & OPpLOCALE) {
2245             TAINT;
2246             SvTAINTED_on(sv);
2247             *s = toUPPER_LC(*s);
2248         }
2249         else
2250             *s = toUPPER(*s);
2251     }
2252
2253     RETURN;
2254 }
2255
2256 PP(pp_lcfirst)
2257 {
2258     djSP;
2259     SV *sv = TOPs;
2260     register U8 *s;
2261     STRLEN slen;
2262
2263     if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2264         I32 ulen;
2265         U8 tmpbuf[10];
2266         U8 *tend;
2267         UV uv = utf8_to_uv(s, &ulen);
2268
2269         if (PL_op->op_private & OPpLOCALE) {
2270             TAINT;
2271             SvTAINTED_on(sv);
2272             uv = toLOWER_LC_uni(uv);
2273         }
2274         else
2275             uv = toLOWER_utf8(s);
2276
2277         tend = uv_to_utf8(tmpbuf, uv);
2278
2279         if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2280             dTARGET;
2281             sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2282             sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2283             SETs(TARG);
2284         }
2285         else {
2286             s = (U8*)SvPV_force(sv, slen);
2287             Copy(tmpbuf, s, ulen, U8);
2288         }
2289         RETURN;
2290     }
2291
2292     if (!SvPADTMP(sv)) {
2293         dTARGET;
2294         sv_setsv(TARG, sv);
2295         sv = TARG;
2296         SETs(sv);
2297     }
2298     s = (U8*)SvPV_force(sv, slen);
2299     if (*s) {
2300         if (PL_op->op_private & OPpLOCALE) {
2301             TAINT;
2302             SvTAINTED_on(sv);
2303             *s = toLOWER_LC(*s);
2304         }
2305         else
2306             *s = toLOWER(*s);
2307     }
2308
2309     SETs(sv);
2310     RETURN;
2311 }
2312
2313 PP(pp_uc)
2314 {
2315     djSP;
2316     SV *sv = TOPs;
2317     register U8 *s;
2318     STRLEN len;
2319
2320     if (IN_UTF8) {
2321         dTARGET;
2322         I32 ulen;
2323         register U8 *d;
2324         U8 *send;
2325
2326         s = (U8*)SvPV(sv,len);
2327         if (!len) {
2328             sv_setpvn(TARG, "", 0);
2329             SETs(TARG);
2330             RETURN;
2331         }
2332
2333         (void)SvUPGRADE(TARG, SVt_PV);
2334         SvGROW(TARG, (len * 2) + 1);
2335         (void)SvPOK_only(TARG);
2336         d = (U8*)SvPVX(TARG);
2337         send = s + len;
2338         if (PL_op->op_private & OPpLOCALE) {
2339             TAINT;
2340             SvTAINTED_on(TARG);
2341             while (s < send) {
2342                 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2343                 s += ulen;
2344             }
2345         }
2346         else {
2347             while (s < send) {
2348                 d = uv_to_utf8(d, toUPPER_utf8( s ));
2349                 s += UTF8SKIP(s);
2350             }
2351         }
2352         *d = '\0';
2353         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2354         SETs(TARG);
2355         RETURN;
2356     }
2357
2358     if (!SvPADTMP(sv)) {
2359         dTARGET;
2360         sv_setsv(TARG, sv);
2361         sv = TARG;
2362         SETs(sv);
2363     }
2364
2365     s = (U8*)SvPV_force(sv, len);
2366     if (len) {
2367         register U8 *send = s + len;
2368
2369         if (PL_op->op_private & OPpLOCALE) {
2370             TAINT;
2371             SvTAINTED_on(sv);
2372             for (; s < send; s++)
2373                 *s = toUPPER_LC(*s);
2374         }
2375         else {
2376             for (; s < send; s++)
2377                 *s = toUPPER(*s);
2378         }
2379     }
2380     RETURN;
2381 }
2382
2383 PP(pp_lc)
2384 {
2385     djSP;
2386     SV *sv = TOPs;
2387     register U8 *s;
2388     STRLEN len;
2389
2390     if (IN_UTF8) {
2391         dTARGET;
2392         I32 ulen;
2393         register U8 *d;
2394         U8 *send;
2395
2396         s = (U8*)SvPV(sv,len);
2397         if (!len) {
2398             sv_setpvn(TARG, "", 0);
2399             SETs(TARG);
2400             RETURN;
2401         }
2402
2403         (void)SvUPGRADE(TARG, SVt_PV);
2404         SvGROW(TARG, (len * 2) + 1);
2405         (void)SvPOK_only(TARG);
2406         d = (U8*)SvPVX(TARG);
2407         send = s + len;
2408         if (PL_op->op_private & OPpLOCALE) {
2409             TAINT;
2410             SvTAINTED_on(TARG);
2411             while (s < send) {
2412                 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2413                 s += ulen;
2414             }
2415         }
2416         else {
2417             while (s < send) {
2418                 d = uv_to_utf8(d, toLOWER_utf8(s));
2419                 s += UTF8SKIP(s);
2420             }
2421         }
2422         *d = '\0';
2423         SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2424         SETs(TARG);
2425         RETURN;
2426     }
2427
2428     if (!SvPADTMP(sv)) {
2429         dTARGET;
2430         sv_setsv(TARG, sv);
2431         sv = TARG;
2432         SETs(sv);
2433     }
2434
2435     s = (U8*)SvPV_force(sv, len);
2436     if (len) {
2437         register U8 *send = s + len;
2438
2439         if (PL_op->op_private & OPpLOCALE) {
2440             TAINT;
2441             SvTAINTED_on(sv);
2442             for (; s < send; s++)
2443                 *s = toLOWER_LC(*s);
2444         }
2445         else {
2446             for (; s < send; s++)
2447                 *s = toLOWER(*s);
2448         }
2449     }
2450     RETURN;
2451 }
2452
2453 PP(pp_quotemeta)
2454 {
2455     djSP; dTARGET;
2456     SV *sv = TOPs;
2457     STRLEN len;
2458     register char *s = SvPV(sv,len);
2459     register char *d;
2460
2461     if (len) {
2462         (void)SvUPGRADE(TARG, SVt_PV);
2463         SvGROW(TARG, (len * 2) + 1);
2464         d = SvPVX(TARG);
2465         if (IN_UTF8) {
2466             while (len) {
2467                 if (*s & 0x80) {
2468                     STRLEN ulen = UTF8SKIP(s);
2469                     if (ulen > len)
2470                         ulen = len;
2471                     len -= ulen;
2472                     while (ulen--)
2473                         *d++ = *s++;
2474                 }
2475                 else {
2476                     if (!isALNUM(*s))
2477                         *d++ = '\\';
2478                     *d++ = *s++;
2479                     len--;
2480                 }
2481             }
2482         }
2483         else {
2484             while (len--) {
2485                 if (!isALNUM(*s))
2486                     *d++ = '\\';
2487                 *d++ = *s++;
2488             }
2489         }
2490         *d = '\0';
2491         SvCUR_set(TARG, d - SvPVX(TARG));
2492         (void)SvPOK_only(TARG);
2493     }
2494     else
2495         sv_setpvn(TARG, s, len);
2496     SETs(TARG);
2497     RETURN;
2498 }
2499
2500 /* Arrays. */
2501
2502 PP(pp_aslice)
2503 {
2504     djSP; dMARK; dORIGMARK;
2505     register SV** svp;
2506     register AV* av = (AV*)POPs;
2507     register I32 lval = PL_op->op_flags & OPf_MOD;
2508     I32 arybase = PL_curcop->cop_arybase;
2509     I32 elem;
2510
2511     if (SvTYPE(av) == SVt_PVAV) {
2512         if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2513             I32 max = -1;
2514             for (svp = MARK + 1; svp <= SP; svp++) {
2515                 elem = SvIVx(*svp);
2516                 if (elem > max)
2517                     max = elem;
2518             }
2519             if (max > AvMAX(av))
2520                 av_extend(av, max);
2521         }
2522         while (++MARK <= SP) {
2523             elem = SvIVx(*MARK);
2524
2525             if (elem > 0)
2526                 elem -= arybase;
2527             svp = av_fetch(av, elem, lval);
2528             if (lval) {
2529                 if (!svp || *svp == &PL_sv_undef)
2530                     DIE(PL_no_aelem, elem);
2531                 if (PL_op->op_private & OPpLVAL_INTRO)
2532                     save_aelem(av, elem, svp);
2533             }
2534             *MARK = svp ? *svp : &PL_sv_undef;
2535         }
2536     }
2537     if (GIMME != G_ARRAY) {
2538         MARK = ORIGMARK;
2539         *++MARK = *SP;
2540         SP = MARK;
2541     }
2542     RETURN;
2543 }
2544
2545 /* Associative arrays. */
2546
2547 PP(pp_each)
2548 {
2549     djSP; dTARGET;
2550     HV *hash = (HV*)POPs;
2551     HE *entry;
2552     I32 gimme = GIMME_V;
2553     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2554
2555     PUTBACK;
2556     /* might clobber stack_sp */
2557     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2558     SPAGAIN;
2559
2560     EXTEND(SP, 2);
2561     if (entry) {
2562         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2563         if (gimme == G_ARRAY) {
2564             PUTBACK;
2565             /* might clobber stack_sp */
2566             sv_setsv(TARG, realhv ?
2567                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2568             SPAGAIN;
2569             PUSHs(TARG);
2570         }
2571     }
2572     else if (gimme == G_SCALAR)
2573         RETPUSHUNDEF;
2574
2575     RETURN;
2576 }
2577
2578 PP(pp_values)
2579 {
2580     return do_kv(ARGS);
2581 }
2582
2583 PP(pp_keys)
2584 {
2585     return do_kv(ARGS);
2586 }
2587
2588 PP(pp_delete)
2589 {
2590     djSP;
2591     I32 gimme = GIMME_V;
2592     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2593     SV *sv;
2594     HV *hv;
2595
2596     if (PL_op->op_private & OPpSLICE) {
2597         dMARK; dORIGMARK;
2598         U32 hvtype;
2599         hv = (HV*)POPs;
2600         hvtype = SvTYPE(hv);
2601         while (++MARK <= SP) {
2602             if (hvtype == SVt_PVHV)
2603                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2604             else
2605                 DIE("Not a HASH reference");
2606             *MARK = sv ? sv : &PL_sv_undef;
2607         }
2608         if (discard)
2609             SP = ORIGMARK;
2610         else if (gimme == G_SCALAR) {
2611             MARK = ORIGMARK;
2612             *++MARK = *SP;
2613             SP = MARK;
2614         }
2615     }
2616     else {
2617         SV *keysv = POPs;
2618         hv = (HV*)POPs;
2619         if (SvTYPE(hv) == SVt_PVHV)
2620             sv = hv_delete_ent(hv, keysv, discard, 0);
2621         else
2622             DIE("Not a HASH reference");
2623         if (!sv)
2624             sv = &PL_sv_undef;
2625         if (!discard)
2626             PUSHs(sv);
2627     }
2628     RETURN;
2629 }
2630
2631 PP(pp_exists)
2632 {
2633     djSP;
2634     SV *tmpsv = POPs;
2635     HV *hv = (HV*)POPs;
2636     if (SvTYPE(hv) == SVt_PVHV) {
2637         if (hv_exists_ent(hv, tmpsv, 0))
2638             RETPUSHYES;
2639     } else if (SvTYPE(hv) == SVt_PVAV) {
2640         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2641             RETPUSHYES;
2642     } else {
2643         DIE("Not a HASH reference");
2644     }
2645     RETPUSHNO;
2646 }
2647
2648 PP(pp_hslice)
2649 {
2650     djSP; dMARK; dORIGMARK;
2651     register HV *hv = (HV*)POPs;
2652     register I32 lval = PL_op->op_flags & OPf_MOD;
2653     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2654
2655     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2656         DIE("Can't localize pseudo-hash element");
2657
2658     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2659         while (++MARK <= SP) {
2660             SV *keysv = *MARK;
2661             SV **svp;
2662             if (realhv) {
2663                 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2664                 svp = he ? &HeVAL(he) : 0;
2665             } else {
2666                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2667             }
2668             if (lval) {
2669                 if (!svp || *svp == &PL_sv_undef) {
2670                     STRLEN n_a;
2671                     DIE(PL_no_helem, SvPV(keysv, n_a));
2672                 }
2673                 if (PL_op->op_private & OPpLVAL_INTRO)
2674                     save_helem(hv, keysv, svp);
2675             }
2676             *MARK = svp ? *svp : &PL_sv_undef;
2677         }
2678     }
2679     if (GIMME != G_ARRAY) {
2680         MARK = ORIGMARK;
2681         *++MARK = *SP;
2682         SP = MARK;
2683     }
2684     RETURN;
2685 }
2686
2687 /* List operators. */
2688
2689 PP(pp_list)
2690 {
2691     djSP; dMARK;
2692     if (GIMME != G_ARRAY) {
2693         if (++MARK <= SP)
2694             *MARK = *SP;                /* unwanted list, return last item */
2695         else
2696             *MARK = &PL_sv_undef;
2697         SP = MARK;
2698     }
2699     RETURN;
2700 }
2701
2702 PP(pp_lslice)
2703 {
2704     djSP;
2705     SV **lastrelem = PL_stack_sp;
2706     SV **lastlelem = PL_stack_base + POPMARK;
2707     SV **firstlelem = PL_stack_base + POPMARK + 1;
2708     register SV **firstrelem = lastlelem + 1;
2709     I32 arybase = PL_curcop->cop_arybase;
2710     I32 lval = PL_op->op_flags & OPf_MOD;
2711     I32 is_something_there = lval;
2712
2713     register I32 max = lastrelem - lastlelem;
2714     register SV **lelem;
2715     register I32 ix;
2716
2717     if (GIMME != G_ARRAY) {
2718         ix = SvIVx(*lastlelem);
2719         if (ix < 0)
2720             ix += max;
2721         else
2722             ix -= arybase;
2723         if (ix < 0 || ix >= max)
2724             *firstlelem = &PL_sv_undef;
2725         else
2726             *firstlelem = firstrelem[ix];
2727         SP = firstlelem;
2728         RETURN;
2729     }
2730
2731     if (max == 0) {
2732         SP = firstlelem - 1;
2733         RETURN;
2734     }
2735
2736     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2737         ix = SvIVx(*lelem);
2738         if (ix < 0) {
2739             ix += max;
2740             if (ix < 0)
2741                 *lelem = &PL_sv_undef;
2742             else if (!(*lelem = firstrelem[ix]))
2743                 *lelem = &PL_sv_undef;
2744         }
2745         else {
2746             ix -= arybase;
2747             if (ix >= max || !(*lelem = firstrelem[ix]))
2748                 *lelem = &PL_sv_undef;
2749         }
2750         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2751             is_something_there = TRUE;
2752     }
2753     if (is_something_there)
2754         SP = lastlelem;
2755     else
2756         SP = firstlelem - 1;
2757     RETURN;
2758 }
2759
2760 PP(pp_anonlist)
2761 {
2762     djSP; dMARK; dORIGMARK;
2763     I32 items = SP - MARK;
2764     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2765     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2766     XPUSHs(av);
2767     RETURN;
2768 }
2769
2770 PP(pp_anonhash)
2771 {
2772     djSP; dMARK; dORIGMARK;
2773     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2774
2775     while (MARK < SP) {
2776         SV* key = *++MARK;
2777         SV *val = NEWSV(46, 0);
2778         if (MARK < SP)
2779             sv_setsv(val, *++MARK);
2780         else if (ckWARN(WARN_UNSAFE))
2781             warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2782         (void)hv_store_ent(hv,key,val,0);
2783     }
2784     SP = ORIGMARK;
2785     XPUSHs((SV*)hv);
2786     RETURN;
2787 }
2788
2789 PP(pp_splice)
2790 {
2791     djSP; dMARK; dORIGMARK;
2792     register AV *ary = (AV*)*++MARK;
2793     register SV **src;
2794     register SV **dst;
2795     register I32 i;
2796     register I32 offset;
2797     register I32 length;
2798     I32 newlen;
2799     I32 after;
2800     I32 diff;
2801     SV **tmparyval = 0;
2802     MAGIC *mg;
2803
2804     if (mg = SvTIED_mg((SV*)ary, 'P')) {
2805         *MARK-- = SvTIED_obj((SV*)ary, mg);
2806         PUSHMARK(MARK);
2807         PUTBACK;
2808         ENTER;
2809         perl_call_method("SPLICE",GIMME_V);
2810         LEAVE;
2811         SPAGAIN;
2812         RETURN;
2813     }
2814
2815     SP++;
2816
2817     if (++MARK < SP) {
2818         offset = i = SvIVx(*MARK);
2819         if (offset < 0)
2820             offset += AvFILLp(ary) + 1;
2821         else
2822             offset -= PL_curcop->cop_arybase;
2823         if (offset < 0)
2824             DIE(PL_no_aelem, i);
2825         if (++MARK < SP) {
2826             length = SvIVx(*MARK++);
2827             if (length < 0) {
2828                 length += AvFILLp(ary) - offset + 1;
2829                 if (length < 0)
2830                     length = 0;
2831             }
2832         }
2833         else
2834             length = AvMAX(ary) + 1;            /* close enough to infinity */
2835     }
2836     else {
2837         offset = 0;
2838         length = AvMAX(ary) + 1;
2839     }
2840     if (offset > AvFILLp(ary) + 1)
2841         offset = AvFILLp(ary) + 1;
2842     after = AvFILLp(ary) + 1 - (offset + length);
2843     if (after < 0) {                            /* not that much array */
2844         length += after;                        /* offset+length now in array */
2845         after = 0;
2846         if (!AvALLOC(ary))
2847             av_extend(ary, 0);
2848     }
2849
2850     /* At this point, MARK .. SP-1 is our new LIST */
2851
2852     newlen = SP - MARK;
2853     diff = newlen - length;
2854     if (newlen && !AvREAL(ary)) {
2855         if (AvREIFY(ary))
2856             av_reify(ary);
2857         else
2858             assert(AvREAL(ary));                /* would leak, so croak */
2859     }
2860
2861     if (diff < 0) {                             /* shrinking the area */
2862         if (newlen) {
2863             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2864             Copy(MARK, tmparyval, newlen, SV*);
2865         }
2866
2867         MARK = ORIGMARK + 1;
2868         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2869             MEXTEND(MARK, length);
2870             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2871             if (AvREAL(ary)) {
2872                 EXTEND_MORTAL(length);
2873                 for (i = length, dst = MARK; i; i--) {
2874                     sv_2mortal(*dst);   /* free them eventualy */
2875                     dst++;
2876                 }
2877             }
2878             MARK += length - 1;
2879         }
2880         else {
2881             *MARK = AvARRAY(ary)[offset+length-1];
2882             if (AvREAL(ary)) {
2883                 sv_2mortal(*MARK);
2884                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2885                     SvREFCNT_dec(*dst++);       /* free them now */
2886             }
2887         }
2888         AvFILLp(ary) += diff;
2889
2890         /* pull up or down? */
2891
2892         if (offset < after) {                   /* easier to pull up */
2893             if (offset) {                       /* esp. if nothing to pull */
2894                 src = &AvARRAY(ary)[offset-1];
2895                 dst = src - diff;               /* diff is negative */
2896                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2897                     *dst-- = *src--;
2898             }
2899             dst = AvARRAY(ary);
2900             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2901             AvMAX(ary) += diff;
2902         }
2903         else {
2904             if (after) {                        /* anything to pull down? */
2905                 src = AvARRAY(ary) + offset + length;
2906                 dst = src + diff;               /* diff is negative */
2907                 Move(src, dst, after, SV*);
2908             }
2909             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2910                                                 /* avoid later double free */
2911         }
2912         i = -diff;
2913         while (i)
2914             dst[--i] = &PL_sv_undef;
2915
2916         if (newlen) {
2917             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2918               newlen; newlen--) {
2919                 *dst = NEWSV(46, 0);
2920                 sv_setsv(*dst++, *src++);
2921             }
2922             Safefree(tmparyval);
2923         }
2924     }
2925     else {                                      /* no, expanding (or same) */
2926         if (length) {
2927             New(452, tmparyval, length, SV*);   /* so remember deletion */
2928             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2929         }
2930
2931         if (diff > 0) {                         /* expanding */
2932
2933             /* push up or down? */
2934
2935             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2936                 if (offset) {
2937                     src = AvARRAY(ary);
2938                     dst = src - diff;
2939                     Move(src, dst, offset, SV*);
2940                 }
2941                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2942                 AvMAX(ary) += diff;
2943                 AvFILLp(ary) += diff;
2944             }
2945             else {
2946                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2947                     av_extend(ary, AvFILLp(ary) + diff);
2948                 AvFILLp(ary) += diff;
2949
2950                 if (after) {
2951                     dst = AvARRAY(ary) + AvFILLp(ary);
2952                     src = dst - diff;
2953                     for (i = after; i; i--) {
2954                         *dst-- = *src--;
2955                     }
2956                 }
2957             }
2958         }
2959
2960         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2961             *dst = NEWSV(46, 0);
2962             sv_setsv(*dst++, *src++);
2963         }
2964         MARK = ORIGMARK + 1;
2965         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2966             if (length) {
2967                 Copy(tmparyval, MARK, length, SV*);
2968                 if (AvREAL(ary)) {
2969                     EXTEND_MORTAL(length);
2970                     for (i = length, dst = MARK; i; i--) {
2971                         sv_2mortal(*dst);       /* free them eventualy */
2972                         dst++;
2973                     }
2974                 }
2975                 Safefree(tmparyval);
2976             }
2977             MARK += length - 1;
2978         }
2979         else if (length--) {
2980             *MARK = tmparyval[length];
2981             if (AvREAL(ary)) {
2982                 sv_2mortal(*MARK);
2983                 while (length-- > 0)
2984                     SvREFCNT_dec(tmparyval[length]);
2985             }
2986             Safefree(tmparyval);
2987         }
2988         else
2989             *MARK = &PL_sv_undef;
2990     }
2991     SP = MARK;
2992     RETURN;
2993 }
2994
2995 PP(pp_push)
2996 {
2997     djSP; dMARK; dORIGMARK; dTARGET;
2998     register AV *ary = (AV*)*++MARK;
2999     register SV *sv = &PL_sv_undef;
3000     MAGIC *mg;
3001
3002     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3003         *MARK-- = SvTIED_obj((SV*)ary, mg);
3004         PUSHMARK(MARK);
3005         PUTBACK;
3006         ENTER;
3007         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3008         LEAVE;
3009         SPAGAIN;
3010     }
3011     else {
3012         /* Why no pre-extend of ary here ? */
3013         for (++MARK; MARK <= SP; MARK++) {
3014             sv = NEWSV(51, 0);
3015             if (*MARK)
3016                 sv_setsv(sv, *MARK);
3017             av_push(ary, sv);
3018         }
3019     }
3020     SP = ORIGMARK;
3021     PUSHi( AvFILL(ary) + 1 );
3022     RETURN;
3023 }
3024
3025 PP(pp_pop)
3026 {
3027     djSP;
3028     AV *av = (AV*)POPs;
3029     SV *sv = av_pop(av);
3030     if (AvREAL(av))
3031         (void)sv_2mortal(sv);
3032     PUSHs(sv);
3033     RETURN;
3034 }
3035
3036 PP(pp_shift)
3037 {
3038     djSP;
3039     AV *av = (AV*)POPs;
3040     SV *sv = av_shift(av);
3041     EXTEND(SP, 1);
3042     if (!sv)
3043         RETPUSHUNDEF;
3044     if (AvREAL(av))
3045         (void)sv_2mortal(sv);
3046     PUSHs(sv);
3047     RETURN;
3048 }
3049
3050 PP(pp_unshift)
3051 {
3052     djSP; dMARK; dORIGMARK; dTARGET;
3053     register AV *ary = (AV*)*++MARK;
3054     register SV *sv;
3055     register I32 i = 0;
3056     MAGIC *mg;
3057
3058     if (mg = SvTIED_mg((SV*)ary, 'P')) {
3059         *MARK-- = SvTIED_obj((SV*)ary, mg);
3060         PUSHMARK(MARK);
3061         PUTBACK;
3062         ENTER;
3063         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3064         LEAVE;
3065         SPAGAIN;
3066     }
3067     else {
3068         av_unshift(ary, SP - MARK);
3069         while (MARK < SP) {
3070             sv = NEWSV(27, 0);
3071             sv_setsv(sv, *++MARK);
3072             (void)av_store(ary, i++, sv);
3073         }
3074     }
3075     SP = ORIGMARK;
3076     PUSHi( AvFILL(ary) + 1 );
3077     RETURN;
3078 }
3079
3080 PP(pp_reverse)
3081 {
3082     djSP; dMARK;
3083     register SV *tmp;
3084     SV **oldsp = SP;
3085
3086     if (GIMME == G_ARRAY) {
3087         MARK++;
3088         while (MARK < SP) {
3089             tmp = *MARK;
3090             *MARK++ = *SP;
3091             *SP-- = tmp;
3092         }
3093         SP = oldsp;
3094     }
3095     else {
3096         register char *up;
3097         register char *down;
3098         register I32 tmp;
3099         dTARGET;
3100         STRLEN len;
3101
3102         if (SP - MARK > 1)
3103             do_join(TARG, &PL_sv_no, MARK, SP);
3104         else
3105             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3106         up = SvPV_force(TARG, len);
3107         if (len > 1) {
3108             if (IN_UTF8) {      /* first reverse each character */
3109                 U8* s = (U8*)SvPVX(TARG);
3110                 U8* send = (U8*)(s + len);
3111                 while (s < send) {
3112                     if (*s < 0x80) {
3113                         s++;
3114                         continue;
3115                     }
3116                     else {
3117                         up = (char*)s;
3118                         s += UTF8SKIP(s);
3119                         down = (char*)(s - 1);
3120                         if (s > send || !((*down & 0xc0) == 0x80)) {
3121                             warn("Malformed UTF-8 character");
3122                             break;
3123                         }
3124                         while (down > up) {
3125                             tmp = *up;
3126                             *up++ = *down;
3127                             *down-- = tmp;
3128                         }
3129                     }
3130                 }
3131                 up = SvPVX(TARG);
3132             }
3133             down = SvPVX(TARG) + len - 1;
3134             while (down > up) {
3135                 tmp = *up;
3136                 *up++ = *down;
3137                 *down-- = tmp;
3138             }
3139             (void)SvPOK_only(TARG);
3140         }
3141         SP = MARK + 1;
3142         SETTARG;
3143     }
3144     RETURN;
3145 }
3146
3147 STATIC SV      *
3148 mul128(SV *sv, U8 m)
3149 {
3150   STRLEN          len;
3151   char           *s = SvPV(sv, len);
3152   char           *t;
3153   U32             i = 0;
3154
3155   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
3156     SV             *tmpNew = newSVpv("0000000000", 10);
3157
3158     sv_catsv(tmpNew, sv);
3159     SvREFCNT_dec(sv);           /* free old sv */
3160     sv = tmpNew;
3161     s = SvPV(sv, len);
3162   }
3163   t = s + len - 1;
3164   while (!*t)                   /* trailing '\0'? */
3165     t--;
3166   while (t > s) {
3167     i = ((*t - '0') << 7) + m;
3168     *(t--) = '0' + (i % 10);
3169     m = i / 10;
3170   }
3171   return (sv);
3172 }
3173
3174 /* Explosives and implosives. */
3175
3176 static const char uuemap[] =
3177     "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3178 static char uudmap[256];        /* Initialised on first use */
3179 #if 'I' == 73 && 'J' == 74
3180 /* On an ASCII/ISO kind of system */
3181 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
3182 #else
3183 /*
3184   Some other sort of character set - use memchr() so we don't match
3185   the null byte.
3186  */
3187 #define ISUUCHAR(ch)    (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3188 #endif
3189
3190 PP(pp_unpack)
3191 {
3192     djSP;
3193     dPOPPOPssrl;
3194     SV **oldsp = SP;
3195     I32 gimme = GIMME_V;
3196     SV *sv;
3197     STRLEN llen;
3198     STRLEN rlen;
3199     register char *pat = SvPV(left, llen);
3200     register char *s = SvPV(right, rlen);
3201     char *strend = s + rlen;
3202     char *strbeg = s;
3203     register char *patend = pat + llen;
3204     I32 datumtype;
3205     register I32 len;
3206     register I32 bits;
3207
3208     /* These must not be in registers: */
3209     I16 ashort;
3210     int aint;
3211     I32 along;
3212 #ifdef HAS_QUAD
3213     Quad_t aquad;
3214 #endif
3215     U16 aushort;
3216     unsigned int auint;
3217     U32 aulong;
3218 #ifdef HAS_QUAD
3219     Uquad_t auquad;
3220 #endif
3221     char *aptr;
3222     float afloat;
3223     double adouble;
3224     I32 checksum = 0;
3225     register U32 culong;
3226     double cdouble;
3227     static char* bitcount = 0;
3228     int commas = 0;
3229
3230     if (gimme != G_ARRAY) {             /* arrange to do first one only */
3231         /*SUPPRESS 530*/
3232         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3233         if (strchr("aAbBhHP", *patend) || *pat == '%') {
3234             patend++;
3235             while (isDIGIT(*patend) || *patend == '*')
3236                 patend++;
3237         }
3238         else
3239             patend++;
3240     }
3241     while (pat < patend) {
3242       reparse:
3243         datumtype = *pat++ & 0xFF;
3244         if (isSPACE(datumtype))
3245             continue;
3246         if (pat >= patend)
3247             len = 1;
3248         else if (*pat == '*') {
3249             len = strend - strbeg;      /* long enough */
3250             pat++;
3251         }
3252         else if (isDIGIT(*pat)) {
3253             len = *pat++ - '0';
3254             while (isDIGIT(*pat))
3255                 len = (len * 10) + (*pat++ - '0');
3256         }
3257         else
3258             len = (datumtype != '@');
3259         switch(datumtype) {
3260         default:
3261             croak("Invalid type in unpack: '%c'", (int)datumtype);
3262         case ',': /* grandfather in commas but with a warning */
3263             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3264                 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3265             break;
3266         case '%':
3267             if (len == 1 && pat[-1] != '1')
3268                 len = 16;
3269             checksum = len;
3270             culong = 0;
3271             cdouble = 0;
3272             if (pat < patend)
3273                 goto reparse;
3274             break;
3275         case '@':
3276             if (len > strend - strbeg)
3277                 DIE("@ outside of string");
3278             s = strbeg + len;
3279             break;
3280         case 'X':
3281             if (len > s - strbeg)
3282                 DIE("X outside of string");
3283             s -= len;
3284             break;
3285         case 'x':
3286             if (len > strend - s)
3287                 DIE("x outside of string");
3288             s += len;
3289             break;
3290         case 'A':
3291         case 'a':
3292             if (len > strend - s)
3293                 len = strend - s;
3294             if (checksum)
3295                 goto uchar_checksum;
3296             sv = NEWSV(35, len);
3297             sv_setpvn(sv, s, len);
3298             s += len;
3299             if (datumtype == 'A') {
3300                 aptr = s;       /* borrow register */
3301                 s = SvPVX(sv) + len - 1;
3302                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3303                     s--;
3304                 *++s = '\0';
3305                 SvCUR_set(sv, s - SvPVX(sv));
3306                 s = aptr;       /* unborrow register */
3307             }
3308             XPUSHs(sv_2mortal(sv));
3309             break;
3310         case 'B':
3311         case 'b':
3312             if (pat[-1] == '*' || len > (strend - s) * 8)
3313                 len = (strend - s) * 8;
3314             if (checksum) {
3315                 if (!bitcount) {
3316                     Newz(601, bitcount, 256, char);
3317                     for (bits = 1; bits < 256; bits++) {
3318                         if (bits & 1)   bitcount[bits]++;
3319                         if (bits & 2)   bitcount[bits]++;
3320                         if (bits & 4)   bitcount[bits]++;
3321                         if (bits & 8)   bitcount[bits]++;
3322                         if (bits & 16)  bitcount[bits]++;
3323                         if (bits & 32)  bitcount[bits]++;
3324                         if (bits & 64)  bitcount[bits]++;
3325                         if (bits & 128) bitcount[bits]++;
3326                     }
3327                 }
3328                 while (len >= 8) {
3329                     culong += bitcount[*(unsigned char*)s++];
3330                     len -= 8;
3331                 }
3332                 if (len) {
3333                     bits = *s;
3334                     if (datumtype == 'b') {
3335                         while (len-- > 0) {
3336                             if (bits & 1) culong++;
3337                             bits >>= 1;
3338                         }
3339                     }
3340                     else {
3341                         while (len-- > 0) {
3342                             if (bits & 128) culong++;
3343                             bits <<= 1;
3344                         }
3345                     }
3346                 }
3347                 break;
3348             }
3349             sv = NEWSV(35, len + 1);
3350             SvCUR_set(sv, len);
3351             SvPOK_on(sv);
3352             aptr = pat;                 /* borrow register */
3353             pat = SvPVX(sv);
3354             if (datumtype == 'b') {
3355                 aint = len;
3356                 for (len = 0; len < aint; len++) {
3357                     if (len & 7)                /*SUPPRESS 595*/
3358                         bits >>= 1;
3359                     else
3360                         bits = *s++;
3361                     *pat++ = '0' + (bits & 1);
3362                 }
3363             }
3364             else {
3365                 aint = len;
3366                 for (len = 0; len < aint; len++) {
3367                     if (len & 7)
3368                         bits <<= 1;
3369                     else
3370                         bits = *s++;
3371                     *pat++ = '0' + ((bits & 128) != 0);
3372                 }
3373             }
3374             *pat = '\0';
3375             pat = aptr;                 /* unborrow register */
3376             XPUSHs(sv_2mortal(sv));
3377             break;
3378         case 'H':
3379         case 'h':
3380             if (pat[-1] == '*' || len > (strend - s) * 2)
3381                 len = (strend - s) * 2;
3382             sv = NEWSV(35, len + 1);
3383             SvCUR_set(sv, len);
3384             SvPOK_on(sv);
3385             aptr = pat;                 /* borrow register */
3386             pat = SvPVX(sv);
3387             if (datumtype == 'h') {
3388                 aint = len;
3389                 for (len = 0; len < aint; len++) {
3390                     if (len & 1)
3391                         bits >>= 4;
3392                     else
3393                         bits = *s++;
3394                     *pat++ = PL_hexdigit[bits & 15];
3395                 }
3396             }
3397             else {
3398                 aint = len;
3399                 for (len = 0; len < aint; len++) {
3400                     if (len & 1)
3401                         bits <<= 4;
3402                     else
3403                         bits = *s++;
3404                     *pat++ = PL_hexdigit[(bits >> 4) & 15];
3405                 }
3406             }
3407             *pat = '\0';
3408             pat = aptr;                 /* unborrow register */
3409             XPUSHs(sv_2mortal(sv));
3410             break;
3411         case 'c':
3412             if (len > strend - s)
3413                 len = strend - s;
3414             if (checksum) {
3415                 while (len-- > 0) {
3416                     aint = *s++;
3417                     if (aint >= 128)    /* fake up signed chars */
3418                         aint -= 256;
3419                     culong += aint;
3420                 }
3421             }
3422             else {
3423                 EXTEND(SP, len);
3424                 EXTEND_MORTAL(len);
3425                 while (len-- > 0) {
3426                     aint = *s++;
3427                     if (aint >= 128)    /* fake up signed chars */
3428                         aint -= 256;
3429                     sv = NEWSV(36, 0);
3430                     sv_setiv(sv, (IV)aint);
3431                     PUSHs(sv_2mortal(sv));
3432                 }
3433             }
3434             break;
3435         case 'C':
3436             if (len > strend - s)
3437                 len = strend - s;
3438             if (checksum) {
3439               uchar_checksum:
3440                 while (len-- > 0) {
3441                     auint = *s++ & 255;
3442                     culong += auint;
3443                 }
3444             }
3445             else {
3446                 EXTEND(SP, len);
3447                 EXTEND_MORTAL(len);
3448                 while (len-- > 0) {
3449                     auint = *s++ & 255;
3450                     sv = NEWSV(37, 0);
3451                     sv_setiv(sv, (IV)auint);
3452                     PUSHs(sv_2mortal(sv));
3453                 }
3454             }
3455             break;
3456         case 'U':
3457             if (len > strend - s)
3458                 len = strend - s;
3459             if (checksum) {
3460                 while (len-- > 0 && s < strend) {
3461                     auint = utf8_to_uv((U8*)s, &along);
3462                     s += along;
3463                     if (checksum > 32)
3464                         cdouble += (double)auint;
3465                     else
3466                         culong += auint;
3467                 }
3468             }
3469             else {
3470                 EXTEND(SP, len);
3471                 EXTEND_MORTAL(len);
3472                 while (len-- > 0 && s < strend) {
3473                     auint = utf8_to_uv((U8*)s, &along);
3474                     s += along;
3475                     sv = NEWSV(37, 0);
3476                     sv_setuv(sv, (UV)auint);
3477                     PUSHs(sv_2mortal(sv));
3478                 }
3479             }
3480             break;
3481         case 's':
3482             along = (strend - s) / SIZE16;
3483             if (len > along)
3484                 len = along;
3485             if (checksum) {
3486                 while (len-- > 0) {
3487                     COPY16(s, &ashort);
3488                     s += SIZE16;
3489                     culong += ashort;
3490                 }
3491             }
3492             else {
3493                 EXTEND(SP, len);
3494                 EXTEND_MORTAL(len);
3495                 while (len-- > 0) {
3496                     COPY16(s, &ashort);
3497                     s += SIZE16;
3498                     sv = NEWSV(38, 0);
3499                     sv_setiv(sv, (IV)ashort);
3500                     PUSHs(sv_2mortal(sv));
3501                 }
3502             }
3503             break;
3504         case 'v':
3505         case 'n':
3506         case 'S':
3507             along = (strend - s) / SIZE16;
3508             if (len > along)
3509                 len = along;
3510             if (checksum) {
3511                 while (len-- > 0) {
3512                     COPY16(s, &aushort);
3513                     s += SIZE16;
3514 #ifdef HAS_NTOHS
3515                     if (datumtype == 'n')
3516                         aushort = PerlSock_ntohs(aushort);
3517 #endif
3518 #ifdef HAS_VTOHS
3519                     if (datumtype == 'v')
3520                         aushort = vtohs(aushort);
3521 #endif
3522                     culong += aushort;
3523                 }
3524             }
3525             else {
3526                 EXTEND(SP, len);
3527                 EXTEND_MORTAL(len);
3528                 while (len-- > 0) {
3529                     COPY16(s, &aushort);
3530                     s += SIZE16;
3531                     sv = NEWSV(39, 0);
3532 #ifdef HAS_NTOHS
3533                     if (datumtype == 'n')
3534                         aushort = PerlSock_ntohs(aushort);
3535 #endif
3536 #ifdef HAS_VTOHS
3537                     if (datumtype == 'v')
3538                         aushort = vtohs(aushort);
3539 #endif
3540                     sv_setiv(sv, (IV)aushort);
3541                     PUSHs(sv_2mortal(sv));
3542                 }
3543             }
3544             break;
3545         case 'i':
3546             along = (strend - s) / sizeof(int);
3547             if (len > along)
3548                 len = along;
3549             if (checksum) {
3550                 while (len-- > 0) {
3551                     Copy(s, &aint, 1, int);
3552                     s += sizeof(int);
3553                     if (checksum > 32)
3554                         cdouble += (double)aint;
3555                     else
3556                         culong += aint;
3557                 }
3558             }
3559             else {
3560                 EXTEND(SP, len);
3561                 EXTEND_MORTAL(len);
3562                 while (len-- > 0) {
3563                     Copy(s, &aint, 1, int);
3564                     s += sizeof(int);
3565                     sv = NEWSV(40, 0);
3566 #ifdef __osf__
3567                     /* Without the dummy below unpack("i", pack("i",-1))
3568                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3569                      * cc with optimization turned on */
3570                     (aint) ?
3571                         sv_setiv(sv, (IV)aint) :
3572 #endif
3573                     sv_setiv(sv, (IV)aint);
3574                     PUSHs(sv_2mortal(sv));
3575                 }
3576             }
3577             break;
3578         case 'I':
3579             along = (strend - s) / sizeof(unsigned int);
3580             if (len > along)
3581                 len = along;
3582             if (checksum) {
3583                 while (len-- > 0) {
3584                     Copy(s, &auint, 1, unsigned int);
3585                     s += sizeof(unsigned int);
3586                     if (checksum > 32)
3587                         cdouble += (double)auint;
3588                     else
3589                         culong += auint;
3590                 }
3591             }
3592             else {
3593                 EXTEND(SP, len);
3594                 EXTEND_MORTAL(len);
3595                 while (len-- > 0) {
3596                     Copy(s, &auint, 1, unsigned int);
3597                     s += sizeof(unsigned int);
3598                     sv = NEWSV(41, 0);
3599                     sv_setuv(sv, (UV)auint);
3600                     PUSHs(sv_2mortal(sv));
3601                 }
3602             }
3603             break;
3604         case 'l':
3605             along = (strend - s) / SIZE32;
3606             if (len > along)
3607                 len = along;
3608             if (checksum) {
3609                 while (len-- > 0) {
3610                     COPY32(s, &along);
3611                     s += SIZE32;
3612                     if (checksum > 32)
3613                         cdouble += (double)along;
3614                     else
3615                         culong += along;
3616                 }
3617             }
3618             else {
3619                 EXTEND(SP, len);
3620                 EXTEND_MORTAL(len);
3621                 while (len-- > 0) {
3622                     COPY32(s, &along);
3623                     s += SIZE32;
3624                     sv = NEWSV(42, 0);
3625                     sv_setiv(sv, (IV)along);
3626                     PUSHs(sv_2mortal(sv));
3627                 }
3628             }
3629             break;
3630         case 'V':
3631         case 'N':
3632         case 'L':
3633             along = (strend - s) / SIZE32;
3634             if (len > along)
3635                 len = along;
3636             if (checksum) {
3637                 while (len-- > 0) {
3638                     COPY32(s, &aulong);
3639                     s += SIZE32;
3640 #ifdef HAS_NTOHL
3641                     if (datumtype == 'N')
3642                         aulong = PerlSock_ntohl(aulong);
3643 #endif
3644 #ifdef HAS_VTOHL
3645                     if (datumtype == 'V')
3646                         aulong = vtohl(aulong);
3647 #endif
3648                     if (checksum > 32)
3649                         cdouble += (double)aulong;
3650                     else
3651                         culong += aulong;
3652                 }
3653             }
3654             else {
3655                 EXTEND(SP, len);
3656                 EXTEND_MORTAL(len);
3657                 while (len-- > 0) {
3658                     COPY32(s, &aulong);
3659                     s += SIZE32;
3660 #ifdef HAS_NTOHL
3661                     if (datumtype == 'N')
3662                         aulong = PerlSock_ntohl(aulong);
3663 #endif
3664 #ifdef HAS_VTOHL
3665                     if (datumtype == 'V')
3666                         aulong = vtohl(aulong);
3667 #endif
3668                     sv = NEWSV(43, 0);
3669                     sv_setuv(sv, (UV)aulong);
3670                     PUSHs(sv_2mortal(sv));
3671                 }
3672             }
3673             break;
3674         case 'p':
3675             along = (strend - s) / sizeof(char*);
3676             if (len > along)
3677                 len = along;
3678             EXTEND(SP, len);
3679             EXTEND_MORTAL(len);
3680             while (len-- > 0) {
3681                 if (sizeof(char*) > strend - s)
3682                     break;
3683                 else {
3684                     Copy(s, &aptr, 1, char*);
3685                     s += sizeof(char*);
3686                 }
3687                 sv = NEWSV(44, 0);
3688                 if (aptr)
3689                     sv_setpv(sv, aptr);
3690                 PUSHs(sv_2mortal(sv));
3691             }
3692             break;
3693         case 'w':
3694             EXTEND(SP, len);
3695             EXTEND_MORTAL(len);
3696             {
3697                 UV auv = 0;
3698                 U32 bytes = 0;
3699
3700                 while ((len > 0) && (s < strend)) {
3701                     auv = (auv << 7) | (*s & 0x7f);
3702                     if (!(*s++ & 0x80)) {
3703                         bytes = 0;
3704                         sv = NEWSV(40, 0);
3705                         sv_setuv(sv, auv);
3706                         PUSHs(sv_2mortal(sv));
3707                         len--;
3708                         auv = 0;
3709                     }
3710                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3711                         char *t;
3712                         STRLEN n_a;
3713
3714                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3715                         while (s < strend) {
3716                             sv = mul128(sv, *s & 0x7f);
3717                             if (!(*s++ & 0x80)) {
3718                                 bytes = 0;
3719                                 break;
3720                             }
3721                         }
3722                         t = SvPV(sv, n_a);
3723                         while (*t == '0')
3724                             t++;
3725                         sv_chop(sv, t);
3726                         PUSHs(sv_2mortal(sv));
3727                         len--;
3728                         auv = 0;
3729                     }
3730                 }
3731                 if ((s >= strend) && bytes)
3732                     croak("Unterminated compressed integer");
3733             }
3734             break;
3735         case 'P':
3736             EXTEND(SP, 1);
3737             if (sizeof(char*) > strend - s)
3738                 break;
3739             else {
3740                 Copy(s, &aptr, 1, char*);
3741                 s += sizeof(char*);
3742             }
3743             sv = NEWSV(44, 0);
3744             if (aptr)
3745                 sv_setpvn(sv, aptr, len);
3746             PUSHs(sv_2mortal(sv));
3747             break;
3748 #ifdef HAS_QUAD
3749         case 'q':
3750             along = (strend - s) / sizeof(Quad_t);
3751             if (len > along)
3752                 len = along;
3753             EXTEND(SP, len);
3754             EXTEND_MORTAL(len);
3755             while (len-- > 0) {
3756                 if (s + sizeof(Quad_t) > strend)
3757                     aquad = 0;
3758                 else {
3759                     Copy(s, &aquad, 1, Quad_t);
3760                     s += sizeof(Quad_t);
3761                 }
3762                 sv = NEWSV(42, 0);
3763                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3764                     sv_setiv(sv, (IV)aquad);
3765                 else
3766                     sv_setnv(sv, (double)aquad);
3767                 PUSHs(sv_2mortal(sv));
3768             }
3769             break;
3770         case 'Q':
3771             along = (strend - s) / sizeof(Quad_t);
3772             if (len > along)
3773                 len = along;
3774             EXTEND(SP, len);
3775             EXTEND_MORTAL(len);
3776             while (len-- > 0) {
3777                 if (s + sizeof(Uquad_t) > strend)
3778                     auquad = 0;
3779                 else {
3780                     Copy(s, &auquad, 1, Uquad_t);
3781                     s += sizeof(Uquad_t);
3782                 }
3783                 sv = NEWSV(43, 0);
3784                 if (auquad <= UV_MAX)
3785                     sv_setuv(sv, (UV)auquad);
3786                 else
3787                     sv_setnv(sv, (double)auquad);
3788                 PUSHs(sv_2mortal(sv));
3789             }
3790             break;
3791 #endif
3792         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3793         case 'f':
3794         case 'F':
3795             along = (strend - s) / sizeof(float);
3796             if (len > along)
3797                 len = along;
3798             if (checksum) {
3799                 while (len-- > 0) {
3800                     Copy(s, &afloat, 1, float);
3801                     s += sizeof(float);
3802                     cdouble += afloat;
3803                 }
3804             }
3805             else {
3806                 EXTEND(SP, len);
3807                 EXTEND_MORTAL(len);
3808                 while (len-- > 0) {
3809                     Copy(s, &afloat, 1, float);
3810                     s += sizeof(float);
3811                     sv = NEWSV(47, 0);
3812                     sv_setnv(sv, (double)afloat);
3813                     PUSHs(sv_2mortal(sv));
3814                 }
3815             }
3816             break;
3817         case 'd':
3818         case 'D':
3819             along = (strend - s) / sizeof(double);
3820             if (len > along)
3821                 len = along;
3822             if (checksum) {
3823                 while (len-- > 0) {
3824                     Copy(s, &adouble, 1, double);
3825                     s += sizeof(double);
3826                     cdouble += adouble;
3827                 }
3828             }
3829             else {
3830                 EXTEND(SP, len);
3831                 EXTEND_MORTAL(len);
3832                 while (len-- > 0) {
3833                     Copy(s, &adouble, 1, double);
3834                     s += sizeof(double);
3835                     sv = NEWSV(48, 0);
3836                     sv_setnv(sv, (double)adouble);
3837                     PUSHs(sv_2mortal(sv));
3838                 }
3839             }
3840             break;
3841         case 'u':
3842             /* MKS:
3843              * Initialise the decode mapping.  By using a table driven
3844              * algorithm, the code will be character-set independent
3845              * (and just as fast as doing character arithmetic)
3846              */
3847             if (uudmap['M'] == 0) {
3848                 int i;
3849
3850                 for (i = 0; i < sizeof(uuemap); i += 1)
3851                     uudmap[uuemap[i]] = i;
3852                 /*
3853                  * Because ' ' and '`' map to the same value,
3854                  * we need to decode them both the same.
3855                  */
3856                 uudmap[' '] = 0;
3857             }
3858
3859             along = (strend - s) * 3 / 4;
3860             sv = NEWSV(42, along);
3861             if (along)
3862                 SvPOK_on(sv);
3863             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3864                 I32 a, b, c, d;
3865                 char hunk[4];
3866
3867                 hunk[3] = '\0';
3868                 len = uudmap[*s++] & 077;
3869                 while (len > 0) {
3870                     if (s < strend && ISUUCHAR(*s))
3871                         a = uudmap[*s++] & 077;
3872                     else
3873                         a = 0;
3874                     if (s < strend && ISUUCHAR(*s))
3875                         b = uudmap[*s++] & 077;
3876                     else
3877                         b = 0;
3878                     if (s < strend && ISUUCHAR(*s))
3879                         c = uudmap[*s++] & 077;
3880                     else
3881                         c = 0;
3882                     if (s < strend && ISUUCHAR(*s))
3883                         d = uudmap[*s++] & 077;
3884                     else
3885                         d = 0;
3886                     hunk[0] = (a << 2) | (b >> 4);
3887                     hunk[1] = (b << 4) | (c >> 2);
3888                     hunk[2] = (c << 6) | d;
3889                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3890                     len -= 3;
3891                 }
3892                 if (*s == '\n')
3893                     s++;
3894                 else if (s[1] == '\n')          /* possible checksum byte */
3895                     s += 2;
3896             }
3897             XPUSHs(sv_2mortal(sv));
3898             break;
3899         }
3900         if (checksum) {
3901             sv = NEWSV(42, 0);
3902             if (strchr("fFdD", datumtype) ||
3903               (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3904                 double trouble;
3905
3906                 adouble = 1.0;
3907                 while (checksum >= 16) {
3908                     checksum -= 16;
3909                     adouble *= 65536.0;
3910                 }
3911                 while (checksum >= 4) {
3912                     checksum -= 4;
3913                     adouble *= 16.0;
3914                 }
3915                 while (checksum--)
3916                     adouble *= 2.0;
3917                 along = (1 << checksum) - 1;
3918                 while (cdouble < 0.0)
3919                     cdouble += adouble;
3920                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3921                 sv_setnv(sv, cdouble);
3922             }
3923             else {
3924                 if (checksum < 32) {
3925                     aulong = (1 << checksum) - 1;
3926                     culong &= aulong;
3927                 }
3928                 sv_setuv(sv, (UV)culong);
3929             }
3930             XPUSHs(sv_2mortal(sv));
3931             checksum = 0;
3932         }
3933     }
3934     if (SP == oldsp && gimme == G_SCALAR)
3935         PUSHs(&PL_sv_undef);
3936     RETURN;
3937 }
3938
3939 STATIC void
3940 doencodes(register SV *sv, register char *s, register I32 len)
3941 {
3942     char hunk[5];
3943
3944     *hunk = uuemap[len];
3945     sv_catpvn(sv, hunk, 1);
3946     hunk[4] = '\0';
3947     while (len > 2) {
3948         hunk[0] = uuemap[(077 & (*s >> 2))];
3949         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3950         hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3951         hunk[3] = uuemap[(077 & (s[2] & 077))];
3952         sv_catpvn(sv, hunk, 4);
3953         s += 3;
3954         len -= 3;
3955     }
3956     if (len > 0) {
3957         char r = (len > 1 ? s[1] : '\0');
3958         hunk[0] = uuemap[(077 & (*s >> 2))];
3959         hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3960         hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3961         hunk[3] = uuemap[0];
3962         sv_catpvn(sv, hunk, 4);
3963     }
3964     sv_catpvn(sv, "\n", 1);
3965 }
3966
3967 STATIC SV      *
3968 is_an_int(char *s, STRLEN l)
3969 {
3970   STRLEN         n_a;
3971   SV             *result = newSVpv("", l);
3972   char           *result_c = SvPV(result, n_a); /* convenience */
3973   char           *out = result_c;
3974   bool            skip = 1;
3975   bool            ignore = 0;
3976
3977   while (*s) {
3978     switch (*s) {
3979     case ' ':
3980       break;
3981     case '+':
3982       if (!skip) {
3983         SvREFCNT_dec(result);
3984         return (NULL);
3985       }
3986       break;
3987     case '0':
3988     case '1':
3989     case '2':
3990     case '3':
3991     case '4':
3992     case '5':
3993     case '6':
3994     case '7':
3995     case '8':
3996     case '9':
3997       skip = 0;
3998       if (!ignore) {
3999         *(out++) = *s;
4000       }
4001       break;
4002     case '.':
4003       ignore = 1;
4004       break;
4005     default:
4006       SvREFCNT_dec(result);
4007       return (NULL);
4008     }
4009     s++;
4010   }
4011   *(out++) = '\0';
4012   SvCUR_set(result, out - result_c);
4013   return (result);
4014 }
4015
4016 STATIC int
4017 div128(SV *pnum, bool *done)
4018                                             /* must be '\0' terminated */
4019
4020 {
4021   STRLEN          len;
4022   char           *s = SvPV(pnum, len);
4023   int             m = 0;
4024   int             r = 0;
4025   char           *t = s;
4026
4027   *done = 1;
4028   while (*t) {
4029     int             i;
4030
4031     i = m * 10 + (*t - '0');
4032     m = i & 0x7F;
4033     r = (i >> 7);               /* r < 10 */
4034     if (r) {
4035       *done = 0;
4036     }
4037     *(t++) = '0' + r;
4038   }
4039   *(t++) = '\0';
4040   SvCUR_set(pnum, (STRLEN) (t - s));
4041   return (m);
4042 }
4043
4044
4045 PP(pp_pack)
4046 {
4047     djSP; dMARK; dORIGMARK; dTARGET;
4048     register SV *cat = TARG;
4049     register I32 items;
4050     STRLEN fromlen;
4051     register char *pat = SvPVx(*++MARK, fromlen);
4052     register char *patend = pat + fromlen;
4053     register I32 len;
4054     I32 datumtype;
4055     SV *fromstr;
4056     /*SUPPRESS 442*/
4057     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4058     static char *space10 = "          ";
4059
4060     /* These must not be in registers: */
4061     char achar;
4062     I16 ashort;
4063     int aint;
4064     unsigned int auint;
4065     I32 along;
4066     U32 aulong;
4067 #ifdef HAS_QUAD
4068     Quad_t aquad;
4069     Uquad_t auquad;
4070 #endif
4071     char *aptr;
4072     float afloat;
4073     double adouble;
4074     int commas = 0;
4075
4076     items = SP - MARK;
4077     MARK++;
4078     sv_setpvn(cat, "", 0);
4079     while (pat < patend) {
4080 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4081         datumtype = *pat++ & 0xFF;
4082         if (isSPACE(datumtype))
4083             continue;
4084         if (*pat == '*') {
4085             len = strchr("@Xxu", datumtype) ? 0 : items;
4086             pat++;
4087         }
4088         else if (isDIGIT(*pat)) {
4089             len = *pat++ - '0';
4090             while (isDIGIT(*pat))
4091                 len = (len * 10) + (*pat++ - '0');
4092         }
4093         else
4094             len = 1;
4095         switch(datumtype) {
4096         default:
4097             croak("Invalid type in pack: '%c'", (int)datumtype);
4098         case ',': /* grandfather in commas but with a warning */
4099             if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4100                 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4101             break;
4102         case '%':
4103             DIE("%% may only be used in unpack");
4104         case '@':
4105             len -= SvCUR(cat);
4106             if (len > 0)
4107                 goto grow;
4108             len = -len;
4109             if (len > 0)
4110                 goto shrink;
4111             break;
4112         case 'X':
4113           shrink:
4114             if (SvCUR(cat) < len)
4115                 DIE("X outside of string");
4116             SvCUR(cat) -= len;
4117             *SvEND(cat) = '\0';
4118             break;
4119         case 'x':
4120           grow:
4121             while (len >= 10) {
4122                 sv_catpvn(cat, null10, 10);
4123                 len -= 10;
4124             }
4125             sv_catpvn(cat, null10, len);
4126             break;
4127         case 'A':
4128         case 'a':
4129             fromstr = NEXTFROM;
4130             aptr = SvPV(fromstr, fromlen);
4131             if (pat[-1] == '*')
4132                 len = fromlen;
4133             if (fromlen > len)
4134                 sv_catpvn(cat, aptr, len);
4135             else {
4136                 sv_catpvn(cat, aptr, fromlen);
4137                 len -= fromlen;
4138                 if (datumtype == 'A') {
4139                     while (len >= 10) {
4140                         sv_catpvn(cat, space10, 10);
4141                         len -= 10;
4142                     }
4143                     sv_catpvn(cat, space10, len);
4144                 }
4145                 else {
4146                     while (len >= 10) {
4147                         sv_catpvn(cat, null10, 10);
4148                         len -= 10;
4149                     }
4150                     sv_catpvn(cat, null10, len);
4151                 }
4152             }
4153             break;
4154         case 'B':
4155         case 'b':
4156             {
4157                 char *savepat = pat;
4158                 I32 saveitems;
4159
4160                 fromstr = NEXTFROM;
4161                 saveitems = items;
4162                 aptr = SvPV(fromstr, fromlen);
4163                 if (pat[-1] == '*')
4164                     len = fromlen;
4165                 pat = aptr;
4166                 aint = SvCUR(cat);
4167                 SvCUR(cat) += (len+7)/8;
4168                 SvGROW(cat, SvCUR(cat) + 1);
4169                 aptr = SvPVX(cat) + aint;
4170                 if (len > fromlen)
4171                     len = fromlen;
4172                 aint = len;
4173                 items = 0;
4174                 if (datumtype == 'B') {
4175                     for (len = 0; len++ < aint;) {
4176                         items |= *pat++ & 1;
4177                         if (len & 7)
4178                             items <<= 1;
4179                         else {
4180                             *aptr++ = items & 0xff;
4181                             items = 0;
4182                         }
4183                     }
4184                 }
4185                 else {
4186                     for (len = 0; len++ < aint;) {
4187                         if (*pat++ & 1)
4188                             items |= 128;
4189                         if (len & 7)
4190                             items >>= 1;
4191                         else {
4192                             *aptr++ = items & 0xff;
4193                             items = 0;
4194                         }
4195                     }
4196                 }
4197                 if (aint & 7) {
4198                     if (datumtype == 'B')
4199                         items <<= 7 - (aint & 7);
4200                     else
4201                         items >>= 7 - (aint & 7);
4202                     *aptr++ = items & 0xff;
4203                 }
4204                 pat = SvPVX(cat) + SvCUR(cat);
4205                 while (aptr <= pat)
4206                     *aptr++ = '\0';
4207
4208                 pat = savepat;
4209                 items = saveitems;
4210             }
4211             break;
4212         case 'H':
4213         case 'h':
4214             {
4215                 char *savepat = pat;
4216                 I32 saveitems;
4217
4218                 fromstr = NEXTFROM;
4219                 saveitems = items;
4220                 aptr = SvPV(fromstr, fromlen);
4221                 if (pat[-1] == '*')
4222                     len = fromlen;
4223                 pat = aptr;
4224                 aint = SvCUR(cat);
4225                 SvCUR(cat) += (len+1)/2;
4226                 SvGROW(cat, SvCUR(cat) + 1);
4227                 aptr = SvPVX(cat) + aint;
4228                 if (len > fromlen)
4229                     len = fromlen;
4230                 aint = len;
4231                 items = 0;
4232                 if (datumtype == 'H') {
4233                     for (len = 0; len++ < aint;) {
4234                         if (isALPHA(*pat))
4235                             items |= ((*pat++ & 15) + 9) & 15;
4236                         else
4237                             items |= *pat++ & 15;
4238                         if (len & 1)
4239                             items <<= 4;
4240                         else {
4241                             *aptr++ = items & 0xff;
4242                             items = 0;
4243                         }
4244                     }
4245                 }
4246                 else {
4247                     for (len = 0; len++ < aint;) {
4248                         if (isALPHA(*pat))
4249                             items |= (((*pat++ & 15) + 9) & 15) << 4;
4250                         else
4251                             items |= (*pat++ & 15) << 4;
4252                         if (len & 1)
4253                             items >>= 4;
4254                         else {
4255                             *aptr++ = items & 0xff;
4256                             items = 0;
4257                         }
4258                     }
4259                 }
4260                 if (aint & 1)
4261                     *aptr++ = items & 0xff;
4262                 pat = SvPVX(cat) + SvCUR(cat);
4263                 while (aptr <= pat)
4264                     *aptr++ = '\0';
4265
4266                 pat = savepat;
4267                 items = saveitems;
4268             }
4269             break;
4270         case 'C':
4271         case 'c':
4272             while (len-- > 0) {
4273                 fromstr = NEXTFROM;
4274                 aint = SvIV(fromstr);
4275                 achar = aint;
4276                 sv_catpvn(cat, &achar, sizeof(char));
4277             }
4278             break;
4279         case 'U':
4280             while (len-- > 0) {
4281                 fromstr = NEXTFROM;
4282                 auint = SvUV(fromstr);
4283                 SvGROW(cat, SvCUR(cat) + 10);
4284                 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4285                                - SvPVX(cat));
4286             }
4287             *SvEND(cat) = '\0';
4288             break;
4289         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
4290         case 'f':
4291         case 'F':
4292             while (len-- > 0) {
4293                 fromstr = NEXTFROM;
4294                 afloat = (float)SvNV(fromstr);
4295                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4296             }
4297             break;
4298         case 'd':
4299         case 'D':
4300             while (len-- > 0) {
4301                 fromstr = NEXTFROM;
4302                 adouble = (double)SvNV(fromstr);
4303                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4304             }
4305             break;
4306         case 'n':
4307             while (len-- > 0) {
4308                 fromstr = NEXTFROM;
4309                 ashort = (I16)SvIV(fromstr);
4310 #ifdef HAS_HTONS
4311                 ashort = PerlSock_htons(ashort);
4312 #endif
4313                 CAT16(cat, &ashort);
4314             }
4315             break;
4316         case 'v':
4317             while (len-- > 0) {
4318                 fromstr = NEXTFROM;
4319                 ashort = (I16)SvIV(fromstr);
4320 #ifdef HAS_HTOVS
4321                 ashort = htovs(ashort);
4322 #endif
4323                 CAT16(cat, &ashort);
4324             }
4325             break;
4326         case 'S':
4327         case 's':
4328             while (len-- > 0) {
4329                 fromstr = NEXTFROM;
4330                 ashort = (I16)SvIV(fromstr);
4331                 CAT16(cat, &ashort);
4332             }
4333             break;
4334         case 'I':
4335             while (len-- > 0) {
4336                 fromstr = NEXTFROM;
4337                 auint = SvUV(fromstr);
4338                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4339             }
4340             break;
4341         case 'w':
4342             while (len-- > 0) {
4343                 fromstr = NEXTFROM;
4344                 adouble = floor(SvNV(fromstr));
4345
4346                 if (adouble < 0)
4347                     croak("Cannot compress negative numbers");
4348
4349                 if (
4350 #ifdef BW_BITS
4351                     adouble <= BW_MASK
4352 #else
4353 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4354                     adouble <= UV_MAX_cxux
4355 #else
4356                     adouble <= UV_MAX
4357 #endif
4358 #endif
4359                     )
4360                 {
4361                     char   buf[1 + sizeof(UV)];
4362                     char  *in = buf + sizeof(buf);
4363                     UV     auv = U_V(adouble);;
4364
4365                     do {
4366                         *--in = (auv & 0x7f) | 0x80;
4367                         auv >>= 7;
4368                     } while (auv);
4369                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4370                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4371                 }
4372                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
4373                     char           *from, *result, *in;
4374                     SV             *norm;
4375                     STRLEN          len;
4376                     bool            done;
4377
4378                     /* Copy string and check for compliance */
4379                     from = SvPV(fromstr, len);
4380                     if ((norm = is_an_int(from, len)) == NULL)
4381                         croak("can compress only unsigned integer");
4382
4383                     New('w', result, len, char);
4384                     in = result + len;
4385                     done = FALSE;
4386                     while (!done)
4387                         *--in = div128(norm, &done) | 0x80;
4388                     result[len - 1] &= 0x7F; /* clear continue bit */
4389                     sv_catpvn(cat, in, (result + len) - in);
4390                     Safefree(result);
4391                     SvREFCNT_dec(norm); /* free norm */
4392                 }
4393                 else if (SvNOKp(fromstr)) {
4394                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4395                     char  *in = buf + sizeof(buf);
4396
4397                     do {
4398                         double next = floor(adouble / 128);
4399                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4400                         if (--in < buf)  /* this cannot happen ;-) */
4401                             croak ("Cannot compress integer");
4402                         adouble = next;
4403                     } while (adouble > 0);
4404                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4405                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4406                 }
4407                 else
4408                     croak("Cannot compress non integer");
4409             }
4410             break;
4411         case 'i':
4412             while (len-- > 0) {
4413                 fromstr = NEXTFROM;
4414                 aint = SvIV(fromstr);
4415                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4416             }
4417             break;
4418         case 'N':
4419             while (len-- > 0) {
4420                 fromstr = NEXTFROM;
4421                 aulong = SvUV(fromstr);
4422 #ifdef HAS_HTONL
4423                 aulong = PerlSock_htonl(aulong);
4424 #endif
4425                 CAT32(cat, &aulong);
4426             }
4427             break;
4428         case 'V':
4429             while (len-- > 0) {
4430                 fromstr = NEXTFROM;
4431                 aulong = SvUV(fromstr);
4432 #ifdef HAS_HTOVL
4433                 aulong = htovl(aulong);
4434 #endif
4435                 CAT32(cat, &aulong);
4436             }
4437             break;
4438         case 'L':
4439             while (len-- > 0) {
4440                 fromstr = NEXTFROM;
4441                 aulong = SvUV(fromstr);
4442                 CAT32(cat, &aulong);
4443             }
4444             break;
4445         case 'l':
4446             while (len-- > 0) {
4447                 fromstr = NEXTFROM;
4448                 along = SvIV(fromstr);
4449                 CAT32(cat, &along);
4450             }
4451             break;
4452 #ifdef HAS_QUAD
4453         case 'Q':
4454             while (len-- > 0) {
4455                 fromstr = NEXTFROM;
4456                 auquad = (Uquad_t)SvIV(fromstr);
4457                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4458             }
4459             break;
4460         case 'q':
4461             while (len-- > 0) {
4462                 fromstr = NEXTFROM;
4463                 aquad = (Quad_t)SvIV(fromstr);
4464                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4465             }
4466             break;
4467 #endif /* HAS_QUAD */
4468         case 'P':
4469             len = 1;            /* assume SV is correct length */
4470             /* FALL THROUGH */
4471         case 'p':
4472             while (len-- > 0) {
4473                 fromstr = NEXTFROM;
4474                 if (fromstr == &PL_sv_undef)
4475                     aptr = NULL;
4476                 else {
4477                     STRLEN n_a;
4478                     /* XXX better yet, could spirit away the string to
4479                      * a safe spot and hang on to it until the result
4480                      * of pack() (and all copies of the result) are
4481                      * gone.
4482                      */
4483                     if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4484                         warner(WARN_UNSAFE,
4485                                 "Attempt to pack pointer to temporary value");
4486                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4487                         aptr = SvPV(fromstr,n_a);
4488                     else
4489                         aptr = SvPV_force(fromstr,n_a);
4490                 }
4491                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4492             }
4493             break;
4494         case 'u':
4495             fromstr = NEXTFROM;
4496             aptr = SvPV(fromstr, fromlen);
4497             SvGROW(cat, fromlen * 4 / 3);
4498             if (len <= 1)
4499                 len = 45;
4500             else
4501                 len = len / 3 * 3;
4502             while (fromlen > 0) {
4503                 I32 todo;
4504
4505                 if (fromlen > len)
4506                     todo = len;
4507                 else
4508                     todo = fromlen;
4509                 doencodes(cat, aptr, todo);
4510                 fromlen -= todo;
4511                 aptr += todo;
4512             }
4513             break;
4514         }
4515     }
4516     SvSETMAGIC(cat);
4517     SP = ORIGMARK;
4518     PUSHs(cat);
4519     RETURN;
4520 }
4521 #undef NEXTFROM
4522
4523
4524 PP(pp_split)
4525 {
4526     djSP; dTARG;
4527     AV *ary;
4528     register I32 limit = POPi;                  /* note, negative is forever */
4529     SV *sv = POPs;
4530     STRLEN len;
4531     register char *s = SvPV(sv, len);
4532     char *strend = s + len;
4533     register PMOP *pm;
4534     register REGEXP *rx;
4535     register SV *dstr;
4536     register char *m;
4537     I32 iters = 0;
4538     I32 maxiters = (strend - s) + 10;
4539     I32 i;
4540     char *orig;
4541     I32 origlimit = limit;
4542     I32 realarray = 0;
4543     I32 base;
4544     AV *oldstack = PL_curstack;
4545     I32 gimme = GIMME_V;
4546     I32 oldsave = PL_savestack_ix;
4547     I32 make_mortal = 1;
4548     MAGIC *mg = (MAGIC *) NULL;
4549
4550 #ifdef DEBUGGING
4551     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4552 #else
4553     pm = (PMOP*)POPs;
4554 #endif
4555     if (!pm || !s)
4556         DIE("panic: do_split");
4557     rx = pm->op_pmregexp;
4558
4559     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4560              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4561
4562     if (pm->op_pmreplroot)
4563         ary = GvAVn((GV*)pm->op_pmreplroot);
4564     else if (gimme != G_ARRAY)
4565 #ifdef USE_THREADS
4566         ary = (AV*)PL_curpad[0];
4567 #else
4568         ary = GvAVn(PL_defgv);
4569 #endif /* USE_THREADS */
4570     else
4571         ary = Nullav;
4572     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4573         realarray = 1;
4574         PUTBACK;
4575         av_extend(ary,0);
4576         av_clear(ary);
4577         SPAGAIN;
4578         if (mg = SvTIED_mg((SV*)ary, 'P')) {
4579             PUSHMARK(SP);
4580             XPUSHs(SvTIED_obj((SV*)ary, mg));
4581         }
4582         else {
4583             if (!AvREAL(ary)) {
4584                 AvREAL_on(ary);
4585                 for (i = AvFILLp(ary); i >= 0; i--)
4586                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
4587             }
4588             /* temporarily switch stacks */
4589             SWITCHSTACK(PL_curstack, ary);
4590             make_mortal = 0;
4591         }
4592     }
4593     base = SP - PL_stack_base;
4594     orig = s;
4595     if (pm->op_pmflags & PMf_SKIPWHITE) {
4596         if (pm->op_pmflags & PMf_LOCALE) {
4597             while (isSPACE_LC(*s))
4598                 s++;
4599         }
4600         else {
4601             while (isSPACE(*s))
4602                 s++;
4603         }
4604     }
4605     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4606         SAVEINT(PL_multiline);
4607         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4608     }
4609
4610     if (!limit)
4611         limit = maxiters + 2;
4612     if (pm->op_pmflags & PMf_WHITE) {
4613         while (--limit) {
4614             m = s;
4615             while (m < strend &&
4616                    !((pm->op_pmflags & PMf_LOCALE)
4617                      ? isSPACE_LC(*m) : isSPACE(*m)))
4618                 ++m;
4619             if (m >= strend)
4620                 break;
4621
4622             dstr = NEWSV(30, m-s);
4623             sv_setpvn(dstr, s, m-s);
4624             if (make_mortal)
4625                 sv_2mortal(dstr);
4626             XPUSHs(dstr);
4627
4628             s = m + 1;
4629             while (s < strend &&
4630                    ((pm->op_pmflags & PMf_LOCALE)
4631                     ? isSPACE_LC(*s) : isSPACE(*s)))
4632                 ++s;
4633         }
4634     }
4635     else if (strEQ("^", rx->precomp)) {
4636         while (--limit) {
4637             /*SUPPRESS 530*/
4638             for (m = s; m < strend && *m != '\n'; m++) ;
4639             m++;
4640             if (m >= strend)
4641                 break;
4642             dstr = NEWSV(30, m-s);
4643             sv_setpvn(dstr, s, m-s);
4644             if (make_mortal)
4645                 sv_2mortal(dstr);
4646             XPUSHs(dstr);
4647             s = m;
4648         }
4649     }
4650     else if (rx->check_substr && !rx->nparens
4651              && (rx->reganch & ROPT_CHECK_ALL)
4652              && !(rx->reganch & ROPT_ANCH)) {
4653         i = SvCUR(rx->check_substr);
4654         if (i == 1 && !SvTAIL(rx->check_substr)) {
4655             i = *SvPVX(rx->check_substr);
4656             while (--limit) {
4657                 /*SUPPRESS 530*/
4658                 for (m = s; m < strend && *m != i; m++) ;
4659                 if (m >= strend)
4660                     break;
4661                 dstr = NEWSV(30, m-s);
4662                 sv_setpvn(dstr, s, m-s);
4663                 if (make_mortal)
4664                     sv_2mortal(dstr);
4665                 XPUSHs(dstr);
4666                 s = m + 1;
4667             }
4668         }
4669         else {
4670 #ifndef lint
4671             while (s < strend && --limit &&
4672               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4673                     rx->check_substr, 0)) )
4674 #endif
4675             {
4676                 dstr = NEWSV(31, m-s);
4677                 sv_setpvn(dstr, s, m-s);
4678                 if (make_mortal)
4679                     sv_2mortal(dstr);
4680                 XPUSHs(dstr);
4681                 s = m + i;
4682             }
4683         }
4684     }
4685     else {
4686         maxiters += (strend - s) * rx->nparens;
4687         while (s < strend && --limit &&
4688                CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4689         {
4690             TAINT_IF(RX_MATCH_TAINTED(rx));
4691             if (rx->subbase
4692               && rx->subbase != orig) {
4693                 m = s;
4694                 s = orig;
4695                 orig = rx->subbase;
4696                 s = orig + (m - s);
4697                 strend = s + (strend - m);
4698             }
4699             m = rx->startp[0];
4700             dstr = NEWSV(32, m-s);
4701             sv_setpvn(dstr, s, m-s);
4702             if (make_mortal)
4703                 sv_2mortal(dstr);
4704             XPUSHs(dstr);
4705             if (rx->nparens) {
4706                 for (i = 1; i <= rx->nparens; i++) {
4707                     s = rx->startp[i];
4708                     m = rx->endp[i];
4709                     if (m && s) {
4710                         dstr = NEWSV(33, m-s);
4711                         sv_setpvn(dstr, s, m-s);
4712                     }
4713                     else
4714                         dstr = NEWSV(33, 0);
4715                     if (make_mortal)
4716                         sv_2mortal(dstr);
4717                     XPUSHs(dstr);
4718                 }
4719             }
4720             s = rx->endp[0];
4721         }
4722     }
4723
4724     LEAVE_SCOPE(oldsave);
4725     iters = (SP - PL_stack_base) - base;
4726     if (iters > maxiters)
4727         DIE("Split loop");
4728
4729     /* keep field after final delim? */
4730     if (s < strend || (iters && origlimit)) {
4731         dstr = NEWSV(34, strend-s);
4732         sv_setpvn(dstr, s, strend-s);
4733         if (make_mortal)
4734             sv_2mortal(dstr);
4735         XPUSHs(dstr);
4736         iters++;
4737     }
4738     else if (!origlimit) {
4739         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4740             iters--, SP--;
4741     }
4742
4743     if (realarray) {
4744         if (!mg) {
4745             SWITCHSTACK(ary, oldstack);
4746             if (SvSMAGICAL(ary)) {
4747                 PUTBACK;
4748                 mg_set((SV*)ary);
4749                 SPAGAIN;
4750             }
4751             if (gimme == G_ARRAY) {
4752                 EXTEND(SP, iters);
4753                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4754                 SP += iters;
4755                 RETURN;
4756             }
4757         }
4758         else {
4759             PUTBACK;
4760             ENTER;
4761             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4762             LEAVE;
4763             SPAGAIN;
4764             if (gimme == G_ARRAY) {
4765                 /* EXTEND should not be needed - we just popped them */
4766                 EXTEND(SP, iters);
4767                 for (i=0; i < iters; i++) {
4768                     SV **svp = av_fetch(ary, i, FALSE);
4769                     PUSHs((svp) ? *svp : &PL_sv_undef);
4770                 }
4771                 RETURN;
4772             }
4773         }
4774     }
4775     else {
4776         if (gimme == G_ARRAY)
4777             RETURN;
4778     }
4779     if (iters || !pm->op_pmreplroot) {
4780         GETTARGET;
4781         PUSHi(iters);
4782         RETURN;
4783     }
4784     RETPUSHUNDEF;
4785 }
4786
4787 #ifdef USE_THREADS
4788 void
4789 unlock_condpair(void *svv)
4790 {
4791     dTHR;
4792     MAGIC *mg = mg_find((SV*)svv, 'm');
4793
4794     if (!mg)
4795         croak("panic: unlock_condpair unlocking non-mutex");
4796     MUTEX_LOCK(MgMUTEXP(mg));
4797     if (MgOWNER(mg) != thr)
4798         croak("panic: unlock_condpair unlocking mutex that we don't own");
4799     MgOWNER(mg) = 0;
4800     COND_SIGNAL(MgOWNERCONDP(mg));
4801     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4802                           (unsigned long)thr, (unsigned long)svv);)
4803     MUTEX_UNLOCK(MgMUTEXP(mg));
4804 }
4805 #endif /* USE_THREADS */
4806
4807 PP(pp_lock)
4808 {
4809     djSP;
4810     dTOPss;
4811     SV *retsv = sv;
4812 #ifdef USE_THREADS
4813     MAGIC *mg;
4814
4815     if (SvROK(sv))
4816         sv = SvRV(sv);
4817
4818     mg = condpair_magic(sv);
4819     MUTEX_LOCK(MgMUTEXP(mg));
4820     if (MgOWNER(mg) == thr)
4821         MUTEX_UNLOCK(MgMUTEXP(mg));
4822     else {
4823         while (MgOWNER(mg))
4824             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4825         MgOWNER(mg) = thr;
4826         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4827                               (unsigned long)thr, (unsigned long)sv);)
4828         MUTEX_UNLOCK(MgMUTEXP(mg));
4829         save_destructor(unlock_condpair, sv);
4830     }
4831 #endif /* USE_THREADS */
4832     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4833         || SvTYPE(retsv) == SVt_PVCV) {
4834         retsv = refto(retsv);
4835     }
4836     SETs(retsv);
4837     RETURN;
4838 }
4839
4840 PP(pp_threadsv)
4841 {
4842     djSP;
4843 #ifdef USE_THREADS
4844     EXTEND(SP, 1);
4845     if (PL_op->op_private & OPpLVAL_INTRO)
4846         PUSHs(*save_threadsv(PL_op->op_targ));
4847     else
4848         PUSHs(THREADSV(PL_op->op_targ));
4849     RETURN;
4850 #else
4851     DIE("tried to access per-thread data in non-threaded perl");
4852 #endif /* USE_THREADS */
4853 }