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