Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume18/perl/part12

Internet Message Format | 1991-04-15 | 51KB

From: [e-mail] (Larry Wall)
Newsgroups: comp.sources.misc
Subject: v18i030:  perl - The perl programming language, Part12/36
Message-ID: <[e-mail]>
Date: 16 Apr 91 00:00:37 GMT
Approved: [e-mail]
X-Checksum-Snefru: c1420864 1532c12a 35434d4b 81715c95

Submitted-by: Larry Wall <[e-mail]>
Posting-number: Volume 18, Issue 30
Archive-name: perl/part12

[There are 36 kits for perl version 4.0.]

#! /bin/sh

# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh.  When all 36 kits have been run, read README.

echo "This is perl 4.0 kit 12 (of 36).  If kit 12 is complete, the line"
echo '"'"End of kit 12 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir t t/op 2>/dev/null
echo Extracting doarg.c
sed >doarg.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: doarg.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:40:14 $
X *
X *    Copyright (c) 1989, Larry Wall
X *
X *    You may distribute under the terms of the GNU General Public License
X *    as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log:    doarg.c,v $
X * Revision 4.0.1.1  91/04/11  17:40:14  lwall
X * patch1: fixed undefined environ problem
X * patch1: fixed debugger coredump on subroutines
X *
X * Revision 4.0  91/03/20  01:06:42  lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
X#include <signal.h>
X#endif
X
Xextern unsigned char fold[];
X
X#ifdef BUGGY_MSC
X #pragma function(memcmp)
X#endif /* BUGGY_MSC */
X
Xint
Xdo_subst(str,arg,sp)
XSTR *str;
XARG *arg;
Xint sp;
X{
X    register SPAT *spat;
X    SPAT *rspat;
X    register STR *dstr;
X    register char *s = str_get(str);
X    char *strend = s + str->str_cur;
X    register char *m;
X    char *c;
X    register char *d;
X    int clen;
X    int iters = 0;
X    int maxiters = (strend - s) + 10;
X    register int i;
X    bool once;
X    char *orig;
X    int safebase;
X
X    rspat = spat = arg[2].arg_ptr.arg_spat;
X    if (!spat || !s)
X    fatal("panic: do_subst");
X    else if (spat->spat_runtime) {
X    nointrp = "|)";
X    (void)eval(spat->spat_runtime,G_SCALAR,sp);
X    m = str_get(dstr = stack->ary_array[sp+1]);
X    nointrp = "";
X    if (spat->spat_regexp) {
X        regfree(spat->spat_regexp);
X        spat->spat_regexp = Null(REGEXP*);    /* required if regcomp pukes */
X    }
X    spat->spat_regexp = regcomp(m,m+dstr->str_cur,
X        spat->spat_flags & SPAT_FOLD);
X    if (spat->spat_flags & SPAT_KEEP) {
X        arg_free(spat->spat_runtime);    /* it won't change, so */
X        spat->spat_runtime = Nullarg;    /* no point compiling again */
X    }
X    }
X#ifdef DEBUGGING
X    if (debug & 8) {
X    deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
X    }
X#endif
X    safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
X      !sawampersand);
X    if (!*spat->spat_regexp->precomp && lastspat)
X    spat = lastspat;
X    orig = m = s;
X    if (hint) {
X    if (hint < s || hint > strend)
X        fatal("panic: hint in do_match");
X    s = hint;
X    hint = Nullch;
X    if (spat->spat_regexp->regback >= 0) {
X        s -= spat->spat_regexp->regback;
X        if (s < m)
X        s = m;
X    }
X    else
X        s = m;
X    }
X    else if (spat->spat_short) {
X    if (spat->spat_flags & SPAT_SCANFIRST) {
X        if (str->str_pok & SP_STUDIED) {
X        if (screamfirst[spat->spat_short->str_rare] < 0)
X            goto nope;
X        else if (!(s = screaminstr(str,spat->spat_short)))
X            goto nope;
X        }
X#ifndef lint
X        else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend,
X          spat->spat_short)))
X        goto nope;
X#endif
X        if (s && spat->spat_regexp->regback >= 0) {
X        ++spat->spat_short->str_u.str_useful;
X        s -= spat->spat_regexp->regback;
X        if (s < m)
X            s = m;
X        }
X        else
X        s = m;
X    }
X    else if (!multiline && (*spat->spat_short->str_ptr != *s ||
X      bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
X        goto nope;
X    if (--spat->spat_short->str_u.str_useful < 0) {
X        str_free(spat->spat_short);
X        spat->spat_short = Nullstr;    /* opt is being useless */
X    }
X    }
X    once = ((rspat->spat_flags & SPAT_ONCE) != 0);
X    if (rspat->spat_flags & SPAT_CONST) {    /* known replacement string? */
X    if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
X        dstr = rspat->spat_repl[1].arg_ptr.arg_str;
X    else {                    /* constant over loop, anyway */
X        (void)eval(rspat->spat_repl,G_SCALAR,sp);
X        dstr = stack->ary_array[sp+1];
X    }
X    c = str_get(dstr);
X    clen = dstr->str_cur;
X    if (clen <= spat->spat_slen + (int)spat->spat_regexp->regback) {
X                    /* can do inplace substitution */
X        if (regexec(spat->spat_regexp, s, strend, orig, 0,
X          str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
X        if (spat->spat_regexp->subbase) /* oops, no we can't */
X            goto long_way;
X        d = s;
X        lastspat = spat;
X        str->str_pok = SP_VALID;    /* disable possible screamer */
X        if (once) {
X            m = spat->spat_regexp->startp[0];
X            d = spat->spat_regexp->endp[0];
X            s = orig;
X            if (m - s > strend - d) {    /* faster to shorten from end */
X            if (clen) {
X                (void)bcopy(c, m, clen);
X                m += clen;
X            }
X            i = strend - d;
X            if (i > 0) {
X                (void)bcopy(d, m, i);
X                m += i;
X            }
X            *m = '\0';
X            str->str_cur = m - s;
X            STABSET(str);
X            str_numset(arg->arg_ptr.arg_str, 1.0);
X            stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X            return sp;
X            }
X            else if (i = m - s) {    /* faster from front */
X            d -= clen;
X            m = d;
X            str_chop(str,d-i);
X            s += i;
X            while (i--)
X                *--d = *--s;
X            if (clen)
X                (void)bcopy(c, m, clen);
X            STABSET(str);
X            str_numset(arg->arg_ptr.arg_str, 1.0);
X            stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X            return sp;
X            }
X            else if (clen) {
X            d -= clen;
X            str_chop(str,d);
X            (void)bcopy(c,d,clen);
X            STABSET(str);
X            str_numset(arg->arg_ptr.arg_str, 1.0);
X            stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X            return sp;
X            }
X            else {
X            str_chop(str,d);
X            STABSET(str);
X            str_numset(arg->arg_ptr.arg_str, 1.0);
X            stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X            return sp;
X            }
X            /* NOTREACHED */
X        }
X        do {
X            if (iters++ > maxiters)
X            fatal("Substitution loop");
X            m = spat->spat_regexp->startp[0];
X            if (i = m - s) {
X            if (s != d)
X                (void)bcopy(s,d,i);
X            d += i;
X            }
X            if (clen) {
X            (void)bcopy(c,d,clen);
X            d += clen;
X            }
X            s = spat->spat_regexp->endp[0];
X        } while (regexec(spat->spat_regexp, s, strend, orig, s == m,
X            Nullstr, TRUE));    /* (don't match same null twice) */
X        if (s != d) {
X            i = strend - s;
X            str->str_cur = d - str->str_ptr + i;
X            (void)bcopy(s,d,i+1);        /* include the Null */
X        }
X        STABSET(str);
X        str_numset(arg->arg_ptr.arg_str, (double)iters);
X        stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X        return sp;
X        }
X        str_numset(arg->arg_ptr.arg_str, 0.0);
X        stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X        return sp;
X    }
X    }
X    else
X    c = Nullch;
X    if (regexec(spat->spat_regexp, s, strend, orig, 0,
X      str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
X    long_way:
X    dstr = Str_new(25,str_len(str));
X    str_nset(dstr,m,s-m);
X    if (spat->spat_regexp->subbase)
X        curspat = spat;
X    lastspat = spat;
X    do {
X        if (iters++ > maxiters)
X        fatal("Substitution loop");
X        if (spat->spat_regexp->subbase
X          && spat->spat_regexp->subbase != orig) {
X        m = s;
X        s = orig;
X        orig = spat->spat_regexp->subbase;
X        s = orig + (m - s);
X        strend = s + (strend - m);
X        }
X        m = spat->spat_regexp->startp[0];
X        str_ncat(dstr,s,m-s);
X        s = spat->spat_regexp->endp[0];
X        if (c) {
X        if (clen)
X            str_ncat(dstr,c,clen);
X        }
X        else {
X        char *mysubbase = spat->spat_regexp->subbase;
X
X        spat->spat_regexp->subbase = Nullch;    /* so recursion works */
X        (void)eval(rspat->spat_repl,G_SCALAR,sp);
X        str_scat(dstr,stack->ary_array[sp+1]);
X        if (spat->spat_regexp->subbase)
X            Safefree(spat->spat_regexp->subbase);
X        spat->spat_regexp->subbase = mysubbase;
X        }
X        if (once)
X        break;
X    } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr,
X        safebase));
X    str_ncat(dstr,s,strend - s);
X    str_replace(str,dstr);
X    STABSET(str);
X    str_numset(arg->arg_ptr.arg_str, (double)iters);
X    stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X    return sp;
X    }
X    str_numset(arg->arg_ptr.arg_str, 0.0);
X    stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X    return sp;
X
Xnope:
X    ++spat->spat_short->str_u.str_useful;
X    str_numset(arg->arg_ptr.arg_str, 0.0);
X    stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X    return sp;
X}
X#ifdef BUGGY_MSC
X #pragma intrinsic(memcmp)
X#endif /* BUGGY_MSC */
X
Xint
Xdo_trans(str,arg)
XSTR *str;
XARG *arg;
X{
X    register short *tbl;
X    register char *s;
X    register int matches = 0;
X    register int ch;
X    register char *send;
X    register char *d;
X    register int squash = arg[2].arg_len & 1;
X
X    tbl = (short*) arg[2].arg_ptr.arg_cval;
X    s = str_get(str);
X    send = s + str->str_cur;
X    if (!tbl || !s)
X    fatal("panic: do_trans");
X#ifdef DEBUGGING
X    if (debug & 8) {
X    deb("2.TBL\n");
X    }
X#endif
X    if (!arg[2].arg_len) {
X    while (s < send) {
X        if ((ch = tbl[*s & 0377]) >= 0) {
X        matches++;
X        *s = ch;
X        }
X        s++;
X    }
X    }
X    else {
X    d = s;
X    while (s < send) {
X        if ((ch = tbl[*s & 0377]) >= 0) {
X        *d = ch;
X        if (matches++ && squash) {
X            if (d[-1] == *d)
X            matches--;
X            else
X            d++;
X        }
X        else
X            d++;
X        }
X        else if (ch == -1)        /* -1 is unmapped character */
X        *d++ = *s;        /* -2 is delete character */
X        s++;
X    }
X    matches += send - d;    /* account for disappeared chars */
X    *d = '\0';
X    str->str_cur = d - str->str_ptr;
X    }
X    STABSET(str);
X    return matches;
X}
X
Xvoid
Xdo_join(str,arglast)
Xregister STR *str;
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items = arglast[2] - sp;
X    register char *delim = str_get(st[sp]);
X    int delimlen = st[sp]->str_cur;
X
X    st += ++sp;
X    if (items-- > 0)
X    str_sset(str, *st++);
X    else
X    str_set(str,"");
X    if (delimlen) {
X    for (; items > 0; items--,st++) {
X        str_ncat(str,delim,delimlen);
X        str_scat(str,*st);
X    }
X    }
X    else {
X    for (; items > 0; items--,st++)
X        str_scat(str,*st);
X    }
X    STABSET(str);
X}
X
Xvoid
Xdo_pack(str,arglast)
Xregister STR *str;
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items;
X    register char *pat = str_get(st[sp]);
X    register char *patend = pat + st[sp]->str_cur;
X    register int len;
X    int datumtype;
X    STR *fromstr;
X    static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
X    static char *space10 = "          ";
X
X    /* These must not be in registers: */
X    char achar;
X    short ashort;
X    int aint;
X    unsigned int auint;
X    long along;
X    unsigned long aulong;
X    char *aptr;
X    float afloat;
X    double adouble;
X
X    items = arglast[2] - sp;
X    st += ++sp;
X    str_nset(str,"",0);
X    while (pat < patend) {
X#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
X    datumtype = *pat++;
X    if (*pat == '*') {
X        len = index("@Xxu",datumtype) ? 0 : items;
X        pat++;
X    }
X    else if (isdigit(*pat)) {
X        len = *pat++ - '0';
X        while (isdigit(*pat))
X        len = (len * 10) + (*pat++ - '0');
X    }
X    else
X        len = 1;
X    switch(datumtype) {
X    default:
X        break;
X    case '%':
X        fatal("% may only be used in unpack");
X    case '@':
X        len -= str->str_cur;
X        if (len > 0)
X        goto grow;
X        len = -len;
X        if (len > 0)
X        goto shrink;
X        break;
X    case 'X':
X      shrink:
X        if (str->str_cur < len)
X        fatal("X outside of string");
X        str->str_cur -= len;
X        str->str_ptr[str->str_cur] = '\0';
X        break;
X    case 'x':
X      grow:
X        while (len >= 10) {
X        str_ncat(str,null10,10);
X        len -= 10;
X        }
X        str_ncat(str,null10,len);
X        break;
X    case 'A':
X    case 'a':
X        fromstr = NEXTFROM;
X        aptr = str_get(fromstr);
X        if (pat[-1] == '*')
X        len = fromstr->str_cur;
X        if (fromstr->str_cur > len)
X        str_ncat(str,aptr,len);
X        else {
X        str_ncat(str,aptr,fromstr->str_cur);
X        len -= fromstr->str_cur;
X        if (datumtype == 'A') {
X            while (len >= 10) {
X            str_ncat(str,space10,10);
X            len -= 10;
X            }
X            str_ncat(str,space10,len);
X        }
X        else {
X            while (len >= 10) {
X            str_ncat(str,null10,10);
X            len -= 10;
X            }
X            str_ncat(str,null10,len);
X        }
X        }
X        break;
X    case 'B':
X    case 'b':
X        {
X        char *savepat = pat;
X        int saveitems = items;
X
X        fromstr = NEXTFROM;
X        aptr = str_get(fromstr);
X        if (pat[-1] == '*')
X            len = fromstr->str_cur;
X        pat = aptr;
X        aint = str->str_cur;
X        str->str_cur += (len+7)/8;
X        STR_GROW(str, str->str_cur + 1);
X        aptr = str->str_ptr + aint;
X        if (len > fromstr->str_cur)
X            len = fromstr->str_cur;
X        aint = len;
X        items = 0;
X        if (datumtype == 'B') {
X            for (len = 0; len++ < aint;) {
X            items |= *pat++ & 1;
X            if (len & 7)
X                items <<= 1;
X            else {
X                *aptr++ = items & 0xff;
X                items = 0;
X            }
X            }
X        }
X        else {
X            for (len = 0; len++ < aint;) {
X            if (*pat++ & 1)
X                items |= 128;
X            if (len & 7)
X                items >>= 1;
X            else {
X                *aptr++ = items & 0xff;
X                items = 0;
X            }
X            }
X        }
X        if (aint & 7) {
X            if (datumtype == 'B')
X            items <<= 7 - (aint & 7);
X            else
X            items >>= 7 - (aint & 7);
X            *aptr++ = items & 0xff;
X        }
X        pat = str->str_ptr + str->str_cur;
X        while (aptr <= pat)
X            *aptr++ = '\0';
X
X        pat = savepat;
X        items = saveitems;
X        }
X        break;
X    case 'H':
X    case 'h':
X        {
X        char *savepat = pat;
X        int saveitems = items;
X
X        fromstr = NEXTFROM;
X        aptr = str_get(fromstr);
X        if (pat[-1] == '*')
X            len = fromstr->str_cur;
X        pat = aptr;
X        aint = str->str_cur;
X        str->str_cur += (len+1)/2;
X        STR_GROW(str, str->str_cur + 1);
X        aptr = str->str_ptr + aint;
X        if (len > fromstr->str_cur)
X            len = fromstr->str_cur;
X        aint = len;
X        items = 0;
X        if (datumtype == 'H') {
X            for (len = 0; len++ < aint;) {
X            if (isalpha(*pat))
X                items |= ((*pat++ & 15) + 9) & 15;
X            else
X                items |= *pat++ & 15;
X            if (len & 1)
X                items <<= 4;
X            else {
X                *aptr++ = items & 0xff;
X                items = 0;
X            }
X            }
X        }
X        else {
X            for (len = 0; len++ < aint;) {
X            if (isalpha(*pat))
X                items |= (((*pat++ & 15) + 9) & 15) << 4;
X            else
X                items |= (*pat++ & 15) << 4;
X            if (len & 1)
X                items >>= 4;
X            else {
X                *aptr++ = items & 0xff;
X                items = 0;
X            }
X            }
X        }
X        if (aint & 1)
X            *aptr++ = items & 0xff;
X        pat = str->str_ptr + str->str_cur;
X        while (aptr <= pat)
X            *aptr++ = '\0';
X
X        pat = savepat;
X        items = saveitems;
X        }
X        break;
X    case 'C':
X    case 'c':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        aint = (int)str_gnum(fromstr);
X        achar = aint;
X        str_ncat(str,&achar,sizeof(char));
X        }
X        break;
X    /* Float and double added by [e-mail]  22/11/89 */
X    case 'f':
X    case 'F':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        afloat = (float)str_gnum(fromstr);
X        str_ncat(str, (char *)&afloat, sizeof (float));
X        }
X        break;
X    case 'd':
X    case 'D':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        adouble = (double)str_gnum(fromstr);
X        str_ncat(str, (char *)&adouble, sizeof (double));
X        }
X        break;
X    case 'n':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        ashort = (short)str_gnum(fromstr);
X#ifdef HAS_HTONS
X        ashort = htons(ashort);
X#endif
X        str_ncat(str,(char*)&ashort,sizeof(short));
X        }
X        break;
X    case 'S':
X    case 's':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        ashort = (short)str_gnum(fromstr);
X        str_ncat(str,(char*)&ashort,sizeof(short));
X        }
X        break;
X    case 'I':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        auint = U_I(str_gnum(fromstr));
X        str_ncat(str,(char*)&auint,sizeof(unsigned int));
X        }
X        break;
X    case 'i':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        aint = (int)str_gnum(fromstr);
X        str_ncat(str,(char*)&aint,sizeof(int));
X        }
X        break;
X    case 'N':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        aulong = U_L(str_gnum(fromstr));
X#ifdef HAS_HTONL
X        aulong = htonl(aulong);
X#endif
X        str_ncat(str,(char*)&aulong,sizeof(unsigned long));
X        }
X        break;
X    case 'L':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        aulong = U_L(str_gnum(fromstr));
X        str_ncat(str,(char*)&aulong,sizeof(unsigned long));
X        }
X        break;
X    case 'l':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        along = (long)str_gnum(fromstr);
X        str_ncat(str,(char*)&along,sizeof(long));
X        }
X        break;
X    case 'p':
X        while (len-- > 0) {
X        fromstr = NEXTFROM;
X        aptr = str_get(fromstr);
X        str_ncat(str,(char*)&aptr,sizeof(char*));
X        }
X        break;
X    case 'u':
X        fromstr = NEXTFROM;
X        aptr = str_get(fromstr);
X        aint = fromstr->str_cur;
X        STR_GROW(str,aint * 4 / 3);
X        if (len <= 1)
X        len = 45;
X        else
X        len = len / 3 * 3;
X        while (aint > 0) {
X        int todo;
X
X        if (aint > len)
X            todo = len;
X        else
X            todo = aint;
X        doencodes(str, aptr, todo);
X        aint -= todo;
X        aptr += todo;
X        }
X        break;
X    }
X    }
X    STABSET(str);
X}
X#undef NEXTFROM
X
Xdoencodes(str, s, len)
Xregister STR *str;
Xregister char *s;
Xregister int len;
X{
X    char hunk[5];
X
X    *hunk = len + ' ';
X    str_ncat(str, hunk, 1);
X    hunk[4] = '\0';
X    while (len > 0) {
X    hunk[0] = ' ' + (077 & (*s >> 2));
X    hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
X    hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
X    hunk[3] = ' ' + (077 & (s[2] & 077));
X    str_ncat(str, hunk, 4);
X    s += 3;
X    len -= 3;
X    }
X    for (s = str->str_ptr; *s; s++) {
X    if (*s == ' ')
X        *s = '`';
X    }
X    str_ncat(str, "\n", 1);
X}
X
Xvoid
Xdo_sprintf(str,len,sarg)
Xregister STR *str;
Xregister int len;
Xregister STR **sarg;
X{
X    register char *s;
X    register char *t;
X    register char *f;
X    bool dolong;
X    char ch;
X    static STR *sargnull = &str_no;
X    register char *send;
X    char *xs;
X    int xlen;
X    double value;
X    char *origs;
X
X    str_set(str,"");
X    len--;            /* don't count pattern string */
X    origs = t = s = str_get(*sarg);
X    send = s + (*sarg)->str_cur;
X    sarg++;
X    for ( ; ; len--) {
X    if (len <= 0 || !*sarg) {
X        sarg = &sargnull;
X        len = 0;
X    }
X    for ( ; t < send && *t != '%'; t++) ;
X    if (t >= send)
X        break;        /* end of format string, ignore extra args */
X    f = t;
X    *buf = '\0';
X    xs = buf;
X    dolong = FALSE;
X    for (t++; t < send; t++) {
X        switch (*t) {
X        default:
X        ch = *(++t);
X        *t = '\0';
X        (void)sprintf(xs,f);
X        len++;
X        xlen = strlen(xs);
X        break;
X        case '0': case '1': case '2': case '3': case '4':
X        case '5': case '6': case '7': case '8': case '9':
X        case '.': case '#': case '-': case '+': case ' ':
X        continue;
X        case 'l':
X        dolong = TRUE;
X        continue;
X        case 'c':
X        ch = *(++t);
X        *t = '\0';
X        xlen = (int)str_gnum(*(sarg++));
X        if (strEQ(f,"%c")) { /* some printfs fail on null chars */
X            *xs = xlen;
X            xs[1] = '\0';
X            xlen = 1;
X        }
X        else {
X            (void)sprintf(xs,f,xlen);
X            xlen = strlen(xs);
X        }
X        break;
X        case 'D':
X        dolong = TRUE;
X        /* FALL THROUGH */
X        case 'd':
X        ch = *(++t);
X        *t = '\0';
X        if (dolong)
X            (void)sprintf(xs,f,(long)str_gnum(*(sarg++)));
X        else
X            (void)sprintf(xs,f,(int)str_gnum(*(sarg++)));
X        xlen = strlen(xs);
X        break;
X        case 'X': case 'O':
X        dolong = TRUE;
X        /* FALL THROUGH */
X        case 'x': case 'o': case 'u':
X        ch = *(++t);
X        *t = '\0';
X        value = str_gnum(*(sarg++));
X        if (dolong)
X            (void)sprintf(xs,f,U_L(value));
X        else
X            (void)sprintf(xs,f,U_I(value));
X        xlen = strlen(xs);
X        break;
X        case 'E': case 'e': case 'f': case 'G': case 'g':
X        ch = *(++t);
X        *t = '\0';
X        (void)sprintf(xs,f,str_gnum(*(sarg++)));
X        xlen = strlen(xs);
X        break;
X        case 's':
X        ch = *(++t);
X        *t = '\0';
X        xs = str_get(*sarg);
X        xlen = (*sarg)->str_cur;
X        if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
X          && xlen == sizeof(STBP)) {
X            STR *tmpstr = Str_new(24,0);
X
X            stab_fullname(tmpstr, ((STAB*)(*sarg))); /* a stab value! */
X            sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
X                    /* reformat to non-binary */
X            xs = tokenbuf;
X            xlen = strlen(tokenbuf);
X            str_free(tmpstr);
X        }
X        sarg++;
X        if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
X            break;        /* so handle simple case */
X        }
X        strcpy(tokenbuf+64,f);    /* sprintf($s,...$s...) */
X        *t = ch;
X        (void)sprintf(buf,tokenbuf+64,xs);
X        xs = buf;
X        xlen = strlen(xs);
X        break;
X        }
X        /* end of switch, copy results */
X        *t = ch;
X        STR_GROW(str, str->str_cur + (f - s) + len + 1);
X        str_ncat(str, s, f - s);
X        str_ncat(str, xs, xlen);
X        s = t;
X        break;        /* break from for loop */
X    }
X    }
X    str_ncat(str, s, t - s);
X    STABSET(str);
X}
X
XSTR *
Xdo_push(ary,arglast)
Xregister ARRAY *ary;
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items = arglast[2] - sp;
X    register STR *str = &str_undef;
X
X    for (st += ++sp; items > 0; items--,st++) {
X    str = Str_new(26,0);
X    if (*st)
X        str_sset(str,*st);
X    (void)apush(ary,str);
X    }
X    return str;
X}
X
Xvoid
Xdo_unshift(ary,arglast)
Xregister ARRAY *ary;
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items = arglast[2] - sp;
X    register STR *str;
X    register int i;
X
X    aunshift(ary,items);
X    i = 0;
X    for (st += ++sp; i < items; i++,st++) {
X    str = Str_new(27,0);
X    str_sset(str,*st);
X    (void)astore(ary,i,str);
X    }
X}
X
Xint
Xdo_subr(arg,gimme,arglast)
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items = arglast[2] - sp;
X    register SUBR *sub;
X    STR *str;
X    STAB *stab;
X    int oldsave = savestack->ary_fill;
X    int oldtmps_base = tmps_base;
X    int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
X    register CSV *csv;
X
X    if ((arg[1].arg_type & A_MASK) == A_WORD)
X    stab = arg[1].arg_ptr.arg_stab;
X    else {
X    STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab);
X
X    if (tmpstr)
X        stab = stabent(str_get(tmpstr),TRUE);
X    else
X        stab = Nullstab;
X    }
X    if (!stab)
X    fatal("Undefined subroutine called");
X    if (!(sub = stab_sub(stab))) {
X    STR *tmpstr = arg[0].arg_ptr.arg_str;
X
X    stab_fullname(tmpstr, stab);
X    fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
X    }
X    if (arg->arg_type == O_DBSUBR && !sub->usersub) {
X    str = stab_val(DBsub);
X    saveitem(str);
X    stab_fullname(str,stab);
X    sub = stab_sub(DBsub);
X    if (!sub)
X        fatal("No DBsub routine");
X    }
X    str = Str_new(15, sizeof(CSV));
X    str->str_state = SS_SCSV;
X    (void)apush(savestack,str);
X    csv = (CSV*)str->str_ptr;
X    csv->sub = sub;
X    csv->stab = stab;
X    csv->curcsv = curcsv;
X    csv->curcmd = curcmd;
X    csv->depth = sub->depth;
X    csv->wantarray = gimme;
X    csv->hasargs = hasargs;
X    curcsv = csv;
X    if (sub->usersub) {
X    csv->hasargs = 0;
X    csv->savearray = Null(ARRAY*);;
X    csv->argarray = Null(ARRAY*);
X    st[sp] = arg->arg_ptr.arg_str;
X    if (!hasargs)
X        items = 0;
X    return (*sub->usersub)(sub->userindex,sp,items);
X    }
X    if (hasargs) {
X    csv->savearray = stab_xarray(defstab);
X    csv->argarray = afake(defstab, items, &st[sp+1]);
X    stab_xarray(defstab) = csv->argarray;
X    }
X    sub->depth++;
X    if (sub->depth >= 2) {    /* save temporaries on recursion? */
X    if (sub->depth == 100 && dowarn)
X        warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
X    savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
X    }
X    tmps_base = tmps_max;
X    sp = cmd_exec(sub->cmd,gimme, --sp);    /* so do it already */
X    st = stack->ary_array;
X
X    tmps_base = oldtmps_base;
X    for (items = arglast[0] + 1; items <= sp; items++)
X    st[items] = str_mortal(st[items]);
X        /* in case restore wipes old str */
X    restorelist(oldsave);
X    return sp;
X}
X
Xint
Xdo_assign(arg,gimme,arglast)
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X
X    register STR **st = stack->ary_array;
X    STR **firstrelem = st + arglast[1] + 1;
X    STR **firstlelem = st + arglast[0] + 1;
X    STR **lastrelem = st + arglast[2];
X    STR **lastlelem = st + arglast[1];
X    register STR **relem;
X    register STR **lelem;
X
X    register STR *str;
X    register ARRAY *ary;
X    register int makelocal;
X    HASH *hash;
X    int i;
X
X    makelocal = (arg->arg_flags & AF_LOCAL);
X    localizing = makelocal;
X    delaymagic = DM_DELAY;        /* catch simultaneous items */
X
X    /* If there's a common identifier on both sides we have to take
X     * special care that assigning the identifier on the left doesn't
X     * clobber a value on the right that's used later in the list.
X     */
X    if (arg->arg_flags & AF_COMMON) {
X    for (relem = firstrelem; relem <= lastrelem; relem++) {
X        if (str = *relem)
X        *relem = str_mortal(str);
X    }
X    }
X    relem = firstrelem;
X    lelem = firstlelem;
X    ary = Null(ARRAY*);
X    hash = Null(HASH*);
X    while (lelem <= lastlelem) {
X    str = *lelem++;
X    if (str->str_state >= SS_HASH) {
X        if (str->str_state == SS_ARY) {
X        if (makelocal)
X            ary = saveary(str->str_u.str_stab);
X        else {
X            ary = stab_array(str->str_u.str_stab);
X            ary->ary_fill = -1;
X        }
X        i = 0;
X        while (relem <= lastrelem) {    /* gobble up all the rest */
X            str = Str_new(28,0);
X            if (*relem)
X            str_sset(str,*relem);
X            *(relem++) = str;
X            (void)astore(ary,i++,str);
X        }
X        }
X        else if (str->str_state == SS_HASH) {
X        char *tmps;
X        STR *tmpstr;
X        int magic = 0;
X        STAB *tmpstab = str->str_u.str_stab;
X
X        if (makelocal)
X            hash = savehash(str->str_u.str_stab);
X        else {
X            hash = stab_hash(str->str_u.str_stab);
X            if (tmpstab == envstab) {
X            magic = 'E';
X            environ[0] = Nullch;
X            }
X            else if (tmpstab == sigstab) {
X            magic = 'S';
X#ifndef NSIG
X#define NSIG 32
X#endif
X            for (i = 1; i < NSIG; i++)
X                signal(i, SIG_DFL);    /* crunch, crunch, crunch */
X            }
X#ifdef SOME_DBM
X            else if (hash->tbl_dbm)
X            magic = 'D';
X#endif
X            hclear(hash, magic == 'D');    /* wipe any dbm file too */
X
X        }
X        while (relem < lastrelem) {    /* gobble up all the rest */
X            if (*relem)
X            str = *(relem++);
X            else
X            str = &str_no, relem++;
X            tmps = str_get(str);
X            tmpstr = Str_new(29,0);
X            if (*relem)
X            str_sset(tmpstr,*relem);    /* value */
X            *(relem++) = tmpstr;
X            (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
X            if (magic) {
X            str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
X            stabset(tmpstr->str_magic, tmpstr);
X            }
X        }
X        }
X        else
X        fatal("panic: do_assign");
X    }
X    else {
X        if (makelocal)
X        saveitem(str);
X        if (relem <= lastrelem) {
X        str_sset(str, *relem);
X        *(relem++) = str;
X        }
X        else {
X        str_sset(str, &str_undef);
X        if (gimme == G_ARRAY) {
X            i = ++lastrelem - firstrelem;
X            relem++;        /* tacky, I suppose */
X            astore(stack,i,str);
X            if (st != stack->ary_array) {
X            st = stack->ary_array;
X            firstrelem = st + arglast[1] + 1;
X            firstlelem = st + arglast[0] + 1;
X            lastlelem = st + arglast[1];
X            lastrelem = st + i;
X            relem = lastrelem + 1;
X            }
X        }
X        }
X        STABSET(str);
X    }
X    }
X    if (delaymagic > 1) {
X    if (delaymagic & DM_REUID) {
X#ifdef HAS_SETREUID
X        setreuid(uid,euid);
X#else
X        if (uid != euid || setuid(uid) < 0)
X        fatal("No setreuid available");
X#endif
X    }
X    if (delaymagic & DM_REGID) {
X#ifdef HAS_SETREGID
X        setregid(gid,egid);
X#else
X        if (gid != egid || setgid(gid) < 0)
X        fatal("No setregid available");
X#endif
X    }
X    }
X    delaymagic = 0;
X    localizing = FALSE;
X    if (gimme == G_ARRAY) {
X    i = lastrelem - firstrelem + 1;
X    if (ary || hash)
X        Copy(firstrelem, firstlelem, i, STR*);
X    return arglast[0] + i;
X    }
X    else {
X    str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1]));
X    *firstlelem = arg->arg_ptr.arg_str;
X    return arglast[0] + 1;
X    }
X}
X
Xint
Xdo_study(str,arg,gimme,arglast)
XSTR *str;
XARG *arg;
Xint gimme;
Xint *arglast;
X{
X    register unsigned char *s;
X    register int pos = str->str_cur;
X    register int ch;
X    register int *sfirst;
X    register int *snext;
X    static int maxscream = -1;
X    static STR *lastscream = Nullstr;
X    int retval;
X    int retarg = arglast[0] + 1;
X
X#ifndef lint
X    s = (unsigned char*)(str_get(str));
X#else
X    s = Null(unsigned char*);
X#endif
X    if (lastscream)
X    lastscream->str_pok &= ~SP_STUDIED;
X    lastscream = str;
X    if (pos <= 0) {
X    retval = 0;
X    goto ret;
X    }
X    if (pos > maxscream) {
X    if (maxscream < 0) {
X        maxscream = pos + 80;
X        New(301,screamfirst, 256, int);
X        New(302,screamnext, maxscream, int);
X    }
X    else {
X        maxscream = pos + pos / 4;
X        Renew(screamnext, maxscream, int);
X    }
X    }
X
X    sfirst = screamfirst;
X    snext = screamnext;
X
X    if (!sfirst || !snext)
X    fatal("do_study: out of memory");
X
X    for (ch = 256; ch; --ch)
X    *sfirst++ = -1;
X    sfirst -= 256;
X
X    while (--pos >= 0) {
X    ch = s[pos];
X    if (sfirst[ch] >= 0)
X        snext[pos] = sfirst[ch] - pos;
X    else
X        snext[pos] = -pos;
X    sfirst[ch] = pos;
X
X    /* If there were any case insensitive searches, we must assume they
X     * all are.  This speeds up insensitive searches much more than
X     * it slows down sensitive ones.
X     */
X    if (sawi)
X        sfirst[fold[ch]] = pos;
X    }
X
X    str->str_pok |= SP_STUDIED;
X    retval = 1;
X  ret:
X    str_numset(arg->arg_ptr.arg_str,(double)retval);
X    stack->ary_array[retarg] = arg->arg_ptr.arg_str;
X    return retarg;
X}
X
Xint
Xdo_defined(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X    register int type;
X    register int retarg = arglast[0] + 1;
X    int retval;
X    ARRAY *ary;
X    HASH *hash;
X
X    if ((arg[1].arg_type & A_MASK) != A_LEXPR)
X    fatal("Illegal argument to defined()");
X    arg = arg[1].arg_ptr.arg_arg;
X    type = arg->arg_type;
X
X    if (type == O_SUBR || type == O_DBSUBR)
X    retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
X    else if (type == O_ARRAY || type == O_LARRAY ||
X         type == O_ASLICE || type == O_LASLICE )
X    retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
X        && ary->ary_max >= 0 );
X    else if (type == O_HASH || type == O_LHASH ||
X         type == O_HSLICE || type == O_LHSLICE )
X    retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
X        && hash->tbl_array);
X    else
X    retval = FALSE;
X    str_numset(str,(double)retval);
X    stack->ary_array[retarg] = str;
X    return retarg;
X}
X
Xint
Xdo_undef(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X    register int type;
X    register STAB *stab;
X    int retarg = arglast[0] + 1;
X
X    if ((arg[1].arg_type & A_MASK) != A_LEXPR)
X    fatal("Illegal argument to undef()");
X    arg = arg[1].arg_ptr.arg_arg;
X    type = arg->arg_type;
X
X    if (type == O_ARRAY || type == O_LARRAY) {
X    stab = arg[1].arg_ptr.arg_stab;
X    afree(stab_xarray(stab));
X    stab_xarray(stab) = Null(ARRAY*);
X    }
X    else if (type == O_HASH || type == O_LHASH) {
X    stab = arg[1].arg_ptr.arg_stab;
X    if (stab == envstab)
X        environ[0] = Nullch;
X    else if (stab == sigstab) {
X        int i;
X
X        for (i = 1; i < NSIG; i++)
X        signal(i, SIG_DFL);    /* munch, munch, munch */
X    }
X    (void)hfree(stab_xhash(stab), TRUE);
X    stab_xhash(stab) = Null(HASH*);
X    }
X    else if (type == O_SUBR || type == O_DBSUBR) {
X    stab = arg[1].arg_ptr.arg_stab;
X    if (stab_sub(stab)) {
X        cmd_free(stab_sub(stab)->cmd);
X        stab_sub(stab)->cmd = Nullcmd;
X        afree(stab_sub(stab)->tosave);
X        Safefree(stab_sub(stab));
X        stab_sub(stab) = Null(SUBR*);
X    }
X    }
X    else
X    fatal("Can't undefine that kind of object");
X    str_numset(str,0.0);
X    stack->ary_array[retarg] = str;
X    return retarg;
X}
X
Xint
Xdo_vec(lvalue,astr,arglast)
Xint lvalue;
XSTR *astr;
Xint *arglast;
X{
X    STR **st = stack->ary_array;
X    int sp = arglast[0];
X    register STR *str = st[++sp];
X    register int offset = (int)str_gnum(st[++sp]);
X    register int size = (int)str_gnum(st[++sp]);
X    unsigned char *s = (unsigned char*)str_get(str);
X    unsigned long retnum;
X    int len;
X
X    sp = arglast[1];
X    offset *= size;        /* turn into bit offset */
X    len = (offset + size + 7) / 8;
X    if (offset < 0 || size < 1)
X    retnum = 0;
X    else if (!lvalue && len > str->str_cur)
X    retnum = 0;
X    else {
X    if (len > str->str_cur) {
X        STR_GROW(str,len);
X        (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
X        str->str_cur = len;
X    }
X    s = (unsigned char*)str_get(str);
X    if (size < 8)
X        retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
X    else {
X        offset >>= 3;
X        if (size == 8)
X        retnum = s[offset];
X        else if (size == 16)
X        retnum = (s[offset] << 8) + s[offset+1];
X        else if (size == 32)
X        retnum = (s[offset] << 24) + (s[offset + 1] << 16) +
X            (s[offset + 2] << 8) + s[offset+3];
X    }
X
X    if (lvalue) {                      /* it's an lvalue! */
X        struct lstring *lstr = (struct lstring*)astr;
X
X        astr->str_magic = str;
X        st[sp]->str_rare = 'v';
X        lstr->lstr_offset = offset;
X        lstr->lstr_len = size;
X    }
X    }
X
X    str_numset(astr,(double)retnum);
X    st[sp] = astr;
X    return sp;
X}
X
Xvoid
Xdo_vecset(mstr,str)
XSTR *mstr;
XSTR *str;
X{
X    struct lstring *lstr = (struct lstring*)str;
X    register int offset;
X    register int size;
X    register unsigned char *s = (unsigned char*)mstr->str_ptr;
X    register unsigned long lval = U_L(str_gnum(str));
X    int mask;
X
X    mstr->str_rare = 0;
X    str->str_magic = Nullstr;
X    offset = lstr->lstr_offset;
X    size = lstr->lstr_len;
X    if (size < 8) {
X    mask = (1 << size) - 1;
X    size = offset & 7;
X    lval &= mask;
X    offset >>= 3;
X    s[offset] &= ~(mask << size);
X    s[offset] |= lval << size;
X    }
X    else {
X    if (size == 8)
X        s[offset] = lval & 255;
X    else if (size == 16) {
X        s[offset] = (lval >> 8) & 255;
X        s[offset+1] = lval & 255;
X    }
X    else if (size == 32) {
X        s[offset] = (lval >> 24) & 255;
X        s[offset+1] = (lval >> 16) & 255;
X        s[offset+2] = (lval >> 8) & 255;
X        s[offset+3] = lval & 255;
X    }
X    }
X}
X
Xdo_chop(astr,str)
Xregister STR *astr;
Xregister STR *str;
X{
X    register char *tmps;
X    register int i;
X    ARRAY *ary;
X    HASH *hash;
X    HENT *entry;
X
X    if (!str)
X    return;
X    if (str->str_state == SS_ARY) {
X    ary = stab_array(str->str_u.str_stab);
X    for (i = 0; i <= ary->ary_fill; i++)
X        do_chop(astr,ary->ary_array[i]);
X    return;
X    }
X    if (str->str_state == SS_HASH) {
X    hash = stab_hash(str->str_u.str_stab);
X    (void)hiterinit(hash);
X    while (entry = hiternext(hash))
X        do_chop(astr,hiterval(hash,entry));
X    return;
X    }
X    tmps = str_get(str);
X    if (!tmps)
X    return;
X    tmps += str->str_cur - (str->str_cur != 0);
X    str_nset(astr,tmps,1);    /* remember last char */
X    *tmps = '\0';                /* wipe it out */
X    str->str_cur = tmps - str->str_ptr;
X    str->str_nok = 0;
X    STABSET(str);
X}
X
Xdo_vop(optype,str,left,right)
XSTR *str;
XSTR *left;
XSTR *right;
X{
X    register char *s;
X    register char *l = str_get(left);
X    register char *r = str_get(right);
X    register int len;
X
X    len = left->str_cur;
X    if (len > right->str_cur)
X    len = right->str_cur;
X    if (str->str_cur > len)
X    str->str_cur = len;
X    else if (str->str_cur < len) {
X    STR_GROW(str,len);
X    (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
X    str->str_cur = len;
X    }
X    s = str->str_ptr;
X    if (!s) {
X    str_nset(str,"",0);
X    s = str->str_ptr;
X    }
X    switch (optype) {
X    case O_BIT_AND:
X    while (len--)
X        *s++ = *l++ & *r++;
X    break;
X    case O_XOR:
X    while (len--)
X        *s++ = *l++ ^ *r++;
X    goto mop_up;
X    case O_BIT_OR:
X    while (len--)
X        *s++ = *l++ | *r++;
X      mop_up:
X    len = str->str_cur;
X    if (right->str_cur > len)
X        str_ncat(str,right->str_ptr+len,right->str_cur - len);
X    else if (left->str_cur > len)
X        str_ncat(str,left->str_ptr+len,left->str_cur - len);
X    break;
X    }
X}
X
Xint
Xdo_syscall(arglast)
Xint *arglast;
X{
X    register STR **st = stack->ary_array;
X    register int sp = arglast[1];
X    register int items = arglast[2] - sp;
X    long arg[8];
X    register int i = 0;
X    int retval = -1;
X
X#ifdef HAS_SYSCALL
X#ifdef TAINT
X    for (st += ++sp; items--; st++)
X    tainted |= (*st)->str_tainted;
X    st = stack->ary_array;
X    sp = arglast[1];
X    items = arglast[2] - sp;
X#endif
X#ifdef TAINT
X    taintproper("Insecure dependency in syscall");
X#endif
X    /* This probably won't work on machines where sizeof(long) != sizeof(int)
X     * or where sizeof(long) != sizeof(char*).  But such machines will
X     * not likely have syscall implemented either, so who cares?
X     */
X    while (items--) {
X    if (st[++sp]->str_nok || !i)
X        arg[i++] = (long)str_gnum(st[sp]);
X#ifndef lint
X    else
X        arg[i++] = (long)st[sp]->str_ptr;
X#endif /* lint */
X    }
X    sp = arglast[1];
X    items = arglast[2] - sp;
X    switch (items) {
X    case 0:
X    fatal("Too few args to syscall");
X    case 1:
X    retval = syscall(arg[0]);
X    break;
X    case 2:
X    retval = syscall(arg[0],arg[1]);
X    break;
X    case 3:
X    retval = syscall(arg[0],arg[1],arg[2]);
X    break;
X    case 4:
X    retval = syscall(arg[0],arg[1],arg[2],arg[3]);
X    break;
X    case 5:
X    retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]);
X    break;
X    case 6:
X    retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]);
X    break;
X    case 7:
X    retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]);
X    break;
X    case 8:
X    retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
X      arg[7]);
X    break;
X    }
X    return retval;
X#else
X    fatal("syscall() unimplemented");
X#endif
X}
X
X
!STUFFY!FUNK!
echo Extracting malloc.c
sed >malloc.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: malloc.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:48:31 $
X *
X * $Log:    malloc.c,v $
X * Revision 4.0.1.1  91/04/11  17:48:31  lwall
X * patch1: Configure now figures out malloc ptr type
X *
X * Revision 4.0  91/03/20  01:28:52  lwall
X * 4.0 baseline.
X *
X */
X
X#ifndef lint
Xstatic char sccsid[] = "@(#)malloc.c    4.3 (Berkeley) 9/16/83";
X
X#ifdef DEBUGGING
X#define RCHECK
X#endif
X/*
X * malloc.c (Caltech) 2/21/82
X * Chris Kingsley, kingsley@cit-20.
X *
X * This is a very fast storage allocator.  It allocates blocks of a small
X * number of different sizes, and keeps free lists of each size.  Blocks that
X * don't exactly fit are passed up to the next larger size.  In this
X * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
X * This is designed for use in a program that uses vast quantities of memory,
X * but bombs when it runs out.
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
Xstatic findbucket(), morecore();
X
X/* I don't much care whether these are defined in sys/types.h--LAW */
X
X#define u_char unsigned char
X#define u_int unsigned int
X#define u_short unsigned short
X
X/*
X * The overhead on a block is at least 4 bytes.  When free, this space
X * contains a pointer to the next free block, and the bottom two bits must
X * be zero.  When in use, the first byte is set to MAGIC, and the second
X * byte is the size index.  The remaining bytes are for alignment.
X * If range checking is enabled and the size of the block fits
X * in two bytes, then the top two bytes hold the size of the requested block
X * plus the range checking words, and the header word MINUS ONE.
X */
Xunion    overhead {
X    union    overhead *ov_next;    /* when free */
X#if ALIGNBYTES > 4
X    double    strut;            /* alignment problems */
X#endif
X    struct {
X        u_char    ovu_magic;    /* magic number */
X        u_char    ovu_index;    /* bucket # */
X#ifdef RCHECK
X        u_short    ovu_size;    /* actual block size */
X        u_int    ovu_rmagic;    /* range magic number */
X#endif
X    } ovu;
X#define    ov_magic    ovu.ovu_magic
X#define    ov_index    ovu.ovu_index
X#define    ov_size        ovu.ovu_size
X#define    ov_rmagic    ovu.ovu_rmagic
X};
X
X#define    MAGIC        0xff        /* magic # on accounting info */
X#define OLDMAGIC    0x7f        /* same after a free() */
X#define RMAGIC        0x55555555    /* magic # on range info */
X#ifdef RCHECK
X#define    RSLOP        sizeof (u_int)
X#else
X#define    RSLOP        0
X#endif
X
X/*
X * nextf[i] is the pointer to the next free block of size 2^(i+3).  The
X * smallest allocatable block is 8 bytes.  The overhead information
X * precedes the data area returned to the user.
X */
X#define    NBUCKETS 30
Xstatic    union overhead *nextf[NBUCKETS];
Xextern    char *sbrk();
X
X#ifdef MSTATS
X/*
X * nmalloc[i] is the difference between the number of mallocs and frees
X * for a given block size.
X */
Xstatic    u_int nmalloc[NBUCKETS];
X#include <stdio.h>
X#endif
X
X#ifdef debug
X#define    ASSERT(p)   if (!(p)) botch("p"); else
Xstatic
Xbotch(s)
X    char *s;
X{
X
X    printf("assertion botched: %s\n", s);
X    abort();
X}
X#else
X#define    ASSERT(p)
X#endif
X
XMALLOCPTRTYPE *
Xmalloc(nbytes)
X    register unsigned nbytes;
X{
X      register union overhead *p;
X      register int bucket = 0;
X      register unsigned shiftr;
X
X    /*
X     * Convert amount of memory requested into
X     * closest block size stored in hash buckets
X     * which satisfies request.  Account for
X     * space used per block for accounting.
X     */
X      nbytes += sizeof (union overhead) + RSLOP;
X      nbytes = (nbytes + 3) &~ 3;
X      shiftr = (nbytes - 1) >> 2;
X    /* apart from this loop, this is O(1) */
X      while (shiftr >>= 1)
X          bucket++;
X    /*
X     * If nothing in hash bucket right now,
X     * request more memory from the system.
X     */
X      if (nextf[bucket] == NULL)
X          morecore(bucket);
X      if ((p = (union overhead *)nextf[bucket]) == NULL)
X          return (NULL);
X    /* remove from linked list */
X#ifdef RCHECK
X    if (*((int*)p) & (sizeof(union overhead) - 1))
X#ifndef I286
X        fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p);
X#else
X        fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p);
X#endif
X#endif
X      nextf[bucket] = p->ov_next;
X    p->ov_magic = MAGIC;
X    p->ov_index= bucket;
X#ifdef MSTATS
X      nmalloc[bucket]++;
X#endif
X#ifdef RCHECK
X    /*
X     * Record allocated size of block and
X     * bound space with magic numbers.
X     */
X      if (nbytes <= 0x10000)
X        p->ov_size = nbytes - 1;
X    p->ov_rmagic = RMAGIC;
X      *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
X#endif
X      return ((char *)(p + 1));
X}
X
X/*
X * Allocate more memory to the indicated bucket.
X */
Xstatic
Xmorecore(bucket)
X    register int bucket;
X{
X      register union overhead *op;
X      register int rnu;       /* 2^rnu bytes will be requested */
X      register int nblks;     /* become nblks blocks of the desired size */
X    register int siz;
X
X      if (nextf[bucket])
X          return;
X    /*
X     * Insure memory is allocated
X     * on a page boundary.  Should
X     * make getpageize call?
X     */
X      op = (union overhead *)sbrk(0);
X#ifndef I286
X      if ((int)op & 0x3ff)
X          (void)sbrk(1024 - ((int)op & 0x3ff));
X#else
X    /* The sbrk(0) call on the I286 always returns the next segment */
X#endif
X
X#ifndef I286
X    /* take 2k unless the block is bigger than that */
X      rnu = (bucket <= 8) ? 11 : bucket + 3;
X#else
X    /* take 16k unless the block is bigger than that
X       (80286s like large segments!)        */
X      rnu = (bucket <= 11) ? 14 : bucket + 3;
X#endif
X      nblks = 1 << (rnu - (bucket + 3));  /* how many blocks to get */
X      if (rnu < bucket)
X        rnu = bucket;
X    op = (union overhead *)sbrk(1 << rnu);
X    /* no more room! */
X      if ((int)op == -1)
X          return;
X    /*
X     * Round up to minimum allocation size boundary
X     * and deduct from block count to reflect.
X     */
X#ifndef I286
X      if ((int)op & 7) {
X          op = (union overhead *)(((int)op + 8) &~ 7);
X          nblks--;
X      }
X#else
X    /* Again, this should always be ok on an 80286 */
X#endif
X    /*
X     * Add new memory allocated to that on
X     * free list for this hash bucket.
X     */
X      nextf[bucket] = op;
X      siz = 1 << (bucket + 3);
X      while (--nblks > 0) {
X        op->ov_next = (union overhead *)((caddr_t)op + siz);
X        op = (union overhead *)((caddr_t)op + siz);
X      }
X}
X
Xvoid
Xfree(cp)
X    char *cp;
X{
X      register int size;
X    register union overhead *op;
X
X      if (cp == NULL)
X          return;
X    op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
X#ifdef debug
X      ASSERT(op->ov_magic == MAGIC);        /* make sure it was in use */
X#else
X    if (op->ov_magic != MAGIC) {
X        warn("%s free() ignored",
X            op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad");
X        return;                /* sanity */
X    }
X    op->ov_magic = OLDMAGIC;
X#endif
X#ifdef RCHECK
X      ASSERT(op->ov_rmagic == RMAGIC);
X    if (op->ov_index <= 13)
X        ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
X#endif
X      ASSERT(op->ov_index < NBUCKETS);
X      size = op->ov_index;
X    op->ov_next = nextf[size];
X      nextf[size] = op;
X#ifdef MSTATS
X      nmalloc[size]--;
X#endif
X}
X
X/*
X * When a program attempts "storage compaction" as mentioned in the
X * old malloc man page, it realloc's an already freed block.  Usually
X * this is the last block it freed; occasionally it might be farther
X * back.  We have to search all the free lists for the block in order
X * to determine its bucket: 1st we make one pass thru the lists
X * checking only the first block in each; if that fails we search
X * ``reall_srchlen'' blocks in each list for a match (the variable
X * is extern so the caller can modify it).  If that fails we just copy
X * however many bytes was given to realloc() and hope it's not huge.
X */
Xint reall_srchlen = 4;    /* 4 should be plenty, -1 =>'s whole list */
X
XMALLOCPTRTYPE *
Xrealloc(cp, nbytes)
X    char *cp;
X    unsigned nbytes;
X{
X      register u_int onb;
X    union overhead *op;
X      char *res;
X    register int i;
X    int was_alloced = 0;
X
X      if (cp == NULL)
X          return (malloc(nbytes));
X    op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
X    if (op->ov_magic == MAGIC) {
X        was_alloced++;
X        i = op->ov_index;
X    } else {
X        /*
X         * Already free, doing "compaction".
X         *
X         * Search for the old block of memory on the
X         * free list.  First, check the most common
X         * case (last element free'd), then (this failing)
X         * the last ``reall_srchlen'' items free'd.
X         * If all lookups fail, then assume the size of
X         * the memory block being realloc'd is the
X         * smallest possible.
X         */
X        if ((i = findbucket(op, 1)) < 0 &&
X            (i = findbucket(op, reall_srchlen)) < 0)
X            i = 0;
X    }
X    onb = (1 << (i + 3)) - sizeof (*op) - RSLOP;
X    /* avoid the copy if same size block */
X    if (was_alloced &&
X        nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) {
X#ifdef RCHECK
X        /*
X         * Record new allocated size of block and
X         * bound space with magic numbers.
X         */
X        if (op->ov_index <= 13) {
X            /*
X             * Convert amount of memory requested into
X             * closest block size stored in hash buckets
X             * which satisfies request.  Account for
X             * space used per block for accounting.
X             */
X            nbytes += sizeof (union overhead) + RSLOP;
X            nbytes = (nbytes + 3) &~ 3;
X            op->ov_size = nbytes - 1;
X            *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
X        }
X#endif
X        return(cp);
X    }
X      if ((res = malloc(nbytes)) == NULL)
X          return (NULL);
X      if (cp != res)            /* common optimization */
X        (void)bcopy(cp, res, (int)((nbytes < onb) ? nbytes : onb));
X      if (was_alloced)
X        free(cp);
X      return (res);
X}
X
X/*
X * Search ``srchlen'' elements of each free list for a block whose
X * header starts at ``freep''.  If srchlen is -1 search the whole list.
X * Return bucket number, or -1 if not found.
X */
Xstatic
Xfindbucket(freep, srchlen)
X    union overhead *freep;
X    int srchlen;
X{
X    register union overhead *p;
X    register int i, j;
X
X    for (i = 0; i < NBUCKETS; i++) {
X        j = 0;
X        for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
X            if (p == freep)
X                return (i);
X            j++;
X        }
X    }
X    return (-1);
X}
X
X#ifdef MSTATS
X/*
X * mstats - print out statistics about malloc
X *
X * Prints two lines of numbers, one showing the length of the free list
X * for each size category, the second showing the number of mallocs -
X * frees for each size category.
X */
Xmstats(s)
X    char *s;
X{
X      register int i, j;
X      register union overhead *p;
X      int totfree = 0,
X      totused = 0;
X
X      fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s);
X      for (i = 0; i < NBUCKETS; i++) {
X          for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
X              ;
X          fprintf(stderr, " %d", j);
X          totfree += j * (1 << (i + 3));
X      }
X      fprintf(stderr, "\nused:\t");
X      for (i = 0; i < NBUCKETS; i++) {
X          fprintf(stderr, " %d", nmalloc[i]);
X          totused += nmalloc[i] * (1 << (i + 3));
X      }
X      fprintf(stderr, "\n\tTotal in use: %d, total free: %d\n",
X        totused, totfree);
X}
X#endif
X#endif /* lint */
!STUFFY!FUNK!
echo Extracting t/op/fork.t
sed >t/op/fork.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: fork.t,v 4.0 91/03/20 01:52:43 lwall Locked $
X
X$| = 1;
Xprint "1..2\n";
X
Xif ($cid = fork) {
X    sleep 2;
X    if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";}
X}
Xelse {
X    $| = 1;
X    print "ok 1\n";
X    sleep 10;
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 12 (of 36)"
cat /dev/null >kit12isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
    if test -f kit${iskit}isdone; then
    run="$run $iskit"
    else
    todo="$todo $iskit"
    fi
done
case $todo in
    '')
    echo "You have run all your kits.  Please read README and then type Configure."
    for combo in *:AA; do
        if test -f "$combo"; then
        realfile=`basename $combo :AA`
        cat $realfile:[A-Z][A-Z] >$realfile
        rm -rf $realfile:[A-Z][A-Z]
        fi
    done
    rm -rf kit*isdone
    chmod 755 Configure
    ;;
    *)  echo "You have run$run."
    echo "You still need to run$todo."
    ;;
esac
: Someone might mail this, so...
exit

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].