lwall@netlabs.com (Larry Wall) (04/16/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 29
Archive-name: perl/part11
[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 11 (of 36). If kit 11 is complete, the line"
echo '"'"End of kit 11 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir 2>/dev/null
echo Extracting dolist.c
sed >dolist.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: dolist.c,v 4.0 91/03/20 01:08:03 lwall Locked $
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: dolist.c,v $
X * Revision 4.0 91/03/20 01:08:03 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X
X#ifdef BUGGY_MSC
X #pragma function(memcmp)
X#endif /* BUGGY_MSC */
X
Xint
Xdo_match(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register SPAT *spat = arg[2].arg_ptr.arg_spat;
X register char *t;
X register int sp = arglast[0] + 1;
X STR *srchstr = st[sp];
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp]->str_cur;
X STR *tmpstr;
X char *myhint = hint;
X
X hint = Nullch;
X if (!spat) {
X if (gimme == G_ARRAY)
X return --sp;
X str_set(str,Yes);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X if (!s)
X fatal("panic: do_match");
X if (spat->spat_flags & SPAT_USED) {
X#ifdef DEBUGGING
X if (debug & 8)
X deb("2.SPAT USED\n");
X#endif
X if (gimme == G_ARRAY)
X return --sp;
X str_set(str,No);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X --sp;
X if (spat->spat_runtime) {
X nointrp = "|)";
X sp = eval(spat->spat_runtime,G_SCALAR,sp);
X st = stack->ary_array;
X t = str_get(tmpstr = st[sp--]);
X nointrp = "";
X#ifdef DEBUGGING
X if (debug & 8)
X deb("2.SPAT /%s/\n",t);
X#endif
X if (spat->spat_regexp) {
X regfree(spat->spat_regexp);
X spat->spat_regexp = Null(REGEXP*); /* crucial if regcomp aborts */
X }
X spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
X spat->spat_flags & SPAT_FOLD);
X if (!*spat->spat_regexp->precomp && lastspat)
X spat = lastspat;
X if (spat->spat_flags & SPAT_KEEP) {
X if (spat->spat_runtime)
X arg_free(spat->spat_runtime); /* it won't change, so */
X spat->spat_runtime = Nullarg; /* no point compiling again */
X }
X if (!spat->spat_regexp->nparens)
X gimme = G_SCALAR; /* accidental array context? */
X if (regexec(spat->spat_regexp, s, strend, s, 0,
X srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
X gimme == G_ARRAY)) {
X if (spat->spat_regexp->subbase)
X curspat = spat;
X lastspat = spat;
X goto gotcha;
X }
X else {
X if (gimme == G_ARRAY)
X return sp;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X }
X else {
X#ifdef DEBUGGING
X if (debug & 8) {
X char ch;
X
X if (spat->spat_flags & SPAT_ONCE)
X ch = '?';
X else
X ch = '/';
X deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
X }
X#endif
X if (!*spat->spat_regexp->precomp && lastspat)
X spat = lastspat;
X t = s;
X if (myhint) {
X if (myhint < s || myhint > strend)
X fatal("panic: hint in do_match");
X s = myhint;
X if (spat->spat_regexp->regback >= 0) {
X s -= spat->spat_regexp->regback;
X if (s < t)
X s = t;
X }
X else
X s = t;
X }
X else if (spat->spat_short) {
X if (spat->spat_flags & SPAT_SCANFIRST) {
X if (srchstr->str_pok & SP_STUDIED) {
X if (screamfirst[spat->spat_short->str_rare] < 0)
X goto nope;
X else if (!(s = screaminstr(srchstr,spat->spat_short)))
X goto nope;
X else if (spat->spat_flags & SPAT_ALL)
X goto yup;
X }
X#ifndef lint
X else if (!(s = fbminstr((unsigned char*)s,
X (unsigned char*)strend, spat->spat_short)))
X goto nope;
X#endif
X else if (spat->spat_flags & SPAT_ALL)
X goto yup;
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 < t)
X s = t;
X }
X else
X s = t;
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 if (!spat->spat_regexp->nparens)
X gimme = G_SCALAR; /* accidental array context? */
X if (regexec(spat->spat_regexp, s, strend, t, 0,
X srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
X gimme == G_ARRAY)) {
X if (spat->spat_regexp->subbase)
X curspat = spat;
X lastspat = spat;
X if (spat->spat_flags & SPAT_ONCE)
X spat->spat_flags |= SPAT_USED;
X goto gotcha;
X }
X else {
X if (gimme == G_ARRAY)
X return sp;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X }
X /*NOTREACHED*/
X
X gotcha:
X if (gimme == G_ARRAY) {
X int iters, i, len;
X
X iters = spat->spat_regexp->nparens;
X if (sp + iters >= stack->ary_max) {
X astore(stack,sp + iters, Nullstr);
X st = stack->ary_array; /* possibly realloced */
X }
X
X for (i = 1; i <= iters; i++) {
X st[++sp] = str_mortal(&str_no);
X if (s = spat->spat_regexp->startp[i]) {
X len = spat->spat_regexp->endp[i] - s;
X if (len > 0)
X str_nset(st[sp],s,len);
X }
X }
X return sp;
X }
X else {
X str_sset(str,&str_yes);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X
Xyup:
X ++spat->spat_short->str_u.str_useful;
X lastspat = spat;
X if (spat->spat_flags & SPAT_ONCE)
X spat->spat_flags |= SPAT_USED;
X if (sawampersand) {
X char *tmps;
X
X if (spat->spat_regexp->subbase)
X Safefree(spat->spat_regexp->subbase);
X tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
X spat->spat_regexp->subend = tmps + (strend-t);
X tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
X spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
X curspat = spat;
X }
X str_sset(str,&str_yes);
X STABSET(str);
X st[++sp] = str;
X return sp;
X
Xnope:
X ++spat->spat_short->str_u.str_useful;
X if (gimme == G_ARRAY)
X return sp;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X}
X
X#ifdef BUGGY_MSC
X #pragma intrinsic(memcmp)
X#endif /* BUGGY_MSC */
X
Xint
Xdo_split(str,spat,limit,gimme,arglast)
XSTR *str;
Xregister SPAT *spat;
Xregister int limit;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0] + 1;
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp--]->str_cur;
X register STR *dstr;
X register char *m;
X int iters = 0;
X int maxiters = (strend - s) + 10;
X int i;
X char *orig;
X int origlimit = limit;
X int realarray = 0;
X
X if (!spat || !s)
X fatal("panic: do_split");
X else if (spat->spat_runtime) {
X nointrp = "|)";
X sp = eval(spat->spat_runtime,G_SCALAR,sp);
X st = stack->ary_array;
X m = str_get(dstr = st[sp--]);
X nointrp = "";
X if (*m == ' ' && dstr->str_cur == 1) {
X str_set(dstr,"\\s+");
X m = dstr->str_ptr;
X spat->spat_flags |= SPAT_SKIPWHITE;
X }
X if (spat->spat_regexp) {
X regfree(spat->spat_regexp);
X spat->spat_regexp = Null(REGEXP*); /* avoid possible double free */
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 (spat->spat_runtime->arg_type == O_ITEM &&
X (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
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 ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
X if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
X realarray = 1;
X if (!(ary->ary_flags & ARF_REAL)) {
X ary->ary_flags |= ARF_REAL;
X for (i = ary->ary_fill; i >= 0; i--)
X ary->ary_array[i] = Nullstr; /* don't free mere refs */
X }
X ary->ary_fill = -1;
X sp = -1; /* temporarily switch stacks */
X }
X else
X ary = stack;
X orig = s;
X if (spat->spat_flags & SPAT_SKIPWHITE) {
X while (isascii(*s) && isspace(*s))
X s++;
X }
X if (!limit)
X limit = maxiters + 2;
X if (strEQ("\\s+",spat->spat_regexp->precomp)) {
X while (--limit) {
X for (m = s; m < strend && !(isascii(*m)&&isspace(*m)); m++) ;
X if (m >= strend)
X break;
X dstr = Str_new(30,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X for (s = m + 1; s < strend && isascii(*s) && isspace(*s); s++) ;
X }
X }
X else if (strEQ("^",spat->spat_regexp->precomp)) {
X while (--limit) {
X for (m = s; m < strend && *m != '\n'; m++) ;
X m++;
X if (m >= strend)
X break;
X dstr = Str_new(30,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X s = m;
X }
X }
X else if (spat->spat_short) {
X i = spat->spat_short->str_cur;
X if (i == 1) {
X int fold = (spat->spat_flags & SPAT_FOLD);
X
X i = *spat->spat_short->str_ptr;
X if (fold && isupper(i))
X i = tolower(i);
X while (--limit) {
X if (fold) {
X for ( m = s;
X m < strend && *m != i &&
X (!isupper(*m) || tolower(*m) != i);
X m++)
X ;
X }
X else
X for (m = s; m < strend && *m != i; m++) ;
X if (m >= strend)
X break;
X dstr = Str_new(30,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X s = m + 1;
X }
X }
X else {
X#ifndef lint
X while (s < strend && --limit &&
X (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
X spat->spat_short)) )
X#endif
X {
X dstr = Str_new(31,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X s = m + i;
X }
X }
X }
X else {
X maxiters += (strend - s) * spat->spat_regexp->nparens;
X while (s < strend && --limit &&
X regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
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 dstr = Str_new(32,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X if (spat->spat_regexp->nparens) {
X for (i = 1; i <= spat->spat_regexp->nparens; i++) {
X s = spat->spat_regexp->startp[i];
X m = spat->spat_regexp->endp[i];
X dstr = Str_new(33,m-s);
X str_nset(dstr,s,m-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X }
X }
X s = spat->spat_regexp->endp[0];
X }
X }
X if (realarray)
X iters = sp + 1;
X else
X iters = sp - arglast[0];
X if (iters > maxiters)
X fatal("Split loop");
X if (s < strend || origlimit) { /* keep field after final delim? */
X dstr = Str_new(34,strend-s);
X str_nset(dstr,s,strend-s);
X if (!realarray)
X str_2mortal(dstr);
X (void)astore(ary, ++sp, dstr);
X iters++;
X }
X else {
X#ifndef I286x
X while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
X iters--,sp--;
X#else
X char *zaps;
X int zapb;
X
X if (iters > 0) {
X zaps = str_get(afetch(ary,sp,FALSE));
X zapb = (int) *zaps;
X }
X
X while (iters > 0 && (!zapb)) {
X iters--,sp--;
X if (iters > 0) {
X zaps = str_get(afetch(ary,iters-1,FALSE));
X zapb = (int) *zaps;
X }
X }
X#endif
X }
X if (realarray) {
X ary->ary_fill = sp;
X if (gimme == G_ARRAY) {
X sp++;
X astore(stack, arglast[0] + 1 + sp, Nullstr);
X Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*);
X return arglast[0] + sp;
X }
X }
X else {
X if (gimme == G_ARRAY)
X return sp;
X }
X sp = arglast[0] + 1;
X str_numset(str,(double)iters);
X STABSET(str);
X st[sp] = str;
X return sp;
X}
X
Xint
Xdo_unpack(str,gimme,arglast)
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0] + 1;
X register char *pat = str_get(st[sp++]);
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp--]->str_cur;
X char *strbeg = s;
X register char *patend = pat + st[sp]->str_cur;
X int datumtype;
X register int len;
X register int bits;
X
X /* These must not be in registers: */
X short ashort;
X int aint;
X long along;
X unsigned short aushort;
X unsigned int auint;
X unsigned long aulong;
X char *aptr;
X float afloat;
X double adouble;
X int checksum = 0;
X unsigned long culong;
X double cdouble;
X
X if (gimme != G_ARRAY) { /* arrange to do first one only */
X for (patend = pat; !isalpha(*patend); patend++);
X if (index("aAbBhH", *patend) || *pat == '%') {
X patend++;
X while (isdigit(*patend) || *patend == '*')
X patend++;
X }
X else
X patend++;
X }
X sp--;
X while (pat < patend) {
X reparse:
X datumtype = *pat++;
X if (pat >= patend)
X len = 1;
X else if (*pat == '*') {
X len = strend - strbeg; /* long enough */
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 = (datumtype != '@');
X switch(datumtype) {
X default:
X break;
X case '%':
X if (len == 1 && pat[-1] != '1')
X len = 16;
X checksum = len;
X culong = 0;
X cdouble = 0;
X if (pat < patend)
X goto reparse;
X break;
X case '@':
X if (len > strend - s)
X fatal("@ outside of string");
X s = strbeg + len;
X break;
X case 'X':
X if (len > s - strbeg)
X fatal("X outside of string");
X s -= len;
X break;
X case 'x':
X if (len > strend - s)
X fatal("x outside of string");
X s += len;
X break;
X case 'A':
X case 'a':
X if (len > strend - s)
X len = strend - s;
X if (checksum)
X goto uchar_checksum;
X str = Str_new(35,len);
X str_nset(str,s,len);
X s += len;
X if (datumtype == 'A') {
X aptr = s; /* borrow register */
X s = str->str_ptr + len - 1;
X while (s >= str->str_ptr && (!*s || (isascii(*s)&&isspace(*s))))
X s--;
X *++s = '\0';
X str->str_cur = s - str->str_ptr;
X s = aptr; /* unborrow register */
X }
X (void)astore(stack, ++sp, str_2mortal(str));
X break;
X case 'B':
X case 'b':
X if (pat[-1] == '*' || len > (strend - s) * 8)
X len = (strend - s) * 8;
X str = Str_new(35, len + 1);
X str->str_cur = len;
X str->str_pok = 1;
X aptr = pat; /* borrow register */
X pat = str->str_ptr;
X if (datumtype == 'b') {
X aint = len;
X for (len = 0; len < aint; len++) {
X if (len & 7)
X bits >>= 1;
X else
X bits = *s++;
X *pat++ = '0' + (bits & 1);
X }
X }
X else {
X aint = len;
X for (len = 0; len < aint; len++) {
X if (len & 7)
X bits <<= 1;
X else
X bits = *s++;
X *pat++ = '0' + ((bits & 128) != 0);
X }
X }
X *pat = '\0';
X pat = aptr; /* unborrow register */
X (void)astore(stack, ++sp, str_2mortal(str));
X break;
X case 'H':
X case 'h':
X if (pat[-1] == '*' || len > (strend - s) * 2)
X len = (strend - s) * 2;
X str = Str_new(35, len + 1);
X str->str_cur = len;
X str->str_pok = 1;
X aptr = pat; /* borrow register */
X pat = str->str_ptr;
X if (datumtype == 'h') {
X aint = len;
X for (len = 0; len < aint; len++) {
X if (len & 1)
X bits >>= 4;
X else
X bits = *s++;
X *pat++ = hexdigit[bits & 15];
X }
X }
X else {
X aint = len;
X for (len = 0; len < aint; len++) {
X if (len & 1)
X bits <<= 4;
X else
X bits = *s++;
X *pat++ = hexdigit[(bits >> 4) & 15];
X }
X }
X *pat = '\0';
X pat = aptr; /* unborrow register */
X (void)astore(stack, ++sp, str_2mortal(str));
X break;
X case 'c':
X if (len > strend - s)
X len = strend - s;
X if (checksum) {
X while (len-- > 0) {
X aint = *s++;
X if (aint >= 128) /* fake up signed chars */
X aint -= 256;
X culong += aint;
X }
X }
X else {
X while (len-- > 0) {
X aint = *s++;
X if (aint >= 128) /* fake up signed chars */
X aint -= 256;
X str = Str_new(36,0);
X str_numset(str,(double)aint);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'C':
X if (len > strend - s)
X len = strend - s;
X if (checksum) {
X uchar_checksum:
X while (len-- > 0) {
X auint = *s++ & 255;
X culong += auint;
X }
X }
X else {
X while (len-- > 0) {
X auint = *s++ & 255;
X str = Str_new(37,0);
X str_numset(str,(double)auint);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 's':
X along = (strend - s) / sizeof(short);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&ashort,sizeof(short));
X s += sizeof(short);
X culong += ashort;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&ashort,sizeof(short));
X s += sizeof(short);
X str = Str_new(38,0);
X str_numset(str,(double)ashort);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'n':
X case 'S':
X along = (strend - s) / sizeof(unsigned short);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&aushort,sizeof(unsigned short));
X s += sizeof(unsigned short);
X#ifdef HAS_NTOHS
X if (datumtype == 'n')
X aushort = ntohs(aushort);
X#endif
X culong += aushort;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&aushort,sizeof(unsigned short));
X s += sizeof(unsigned short);
X str = Str_new(39,0);
X#ifdef HAS_NTOHS
X if (datumtype == 'n')
X aushort = ntohs(aushort);
X#endif
X str_numset(str,(double)aushort);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'i':
X along = (strend - s) / sizeof(int);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&aint,sizeof(int));
X s += sizeof(int);
X if (checksum > 32)
X cdouble += (double)aint;
X else
X culong += aint;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&aint,sizeof(int));
X s += sizeof(int);
X str = Str_new(40,0);
X str_numset(str,(double)aint);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'I':
X along = (strend - s) / sizeof(unsigned int);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&auint,sizeof(unsigned int));
X s += sizeof(unsigned int);
X if (checksum > 32)
X cdouble += (double)auint;
X else
X culong += auint;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&auint,sizeof(unsigned int));
X s += sizeof(unsigned int);
X str = Str_new(41,0);
X str_numset(str,(double)auint);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'l':
X along = (strend - s) / sizeof(long);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&along,sizeof(long));
X s += sizeof(long);
X if (checksum > 32)
X cdouble += (double)along;
X else
X culong += along;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&along,sizeof(long));
X s += sizeof(long);
X str = Str_new(42,0);
X str_numset(str,(double)along);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'N':
X case 'L':
X along = (strend - s) / sizeof(unsigned long);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s,(char*)&aulong,sizeof(unsigned long));
X s += sizeof(unsigned long);
X#ifdef HAS_NTOHL
X if (datumtype == 'N')
X aulong = ntohl(aulong);
X#endif
X if (checksum > 32)
X cdouble += (double)aulong;
X else
X culong += aulong;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s,(char*)&aulong,sizeof(unsigned long));
X s += sizeof(unsigned long);
X str = Str_new(43,0);
X#ifdef HAS_NTOHL
X if (datumtype == 'N')
X aulong = ntohl(aulong);
X#endif
X str_numset(str,(double)aulong);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'p':
X along = (strend - s) / sizeof(char*);
X if (len > along)
X len = along;
X while (len-- > 0) {
X if (sizeof(char*) > strend - s)
X break;
X else {
X bcopy(s,(char*)&aptr,sizeof(char*));
X s += sizeof(char*);
X }
X str = Str_new(44,0);
X if (aptr)
X str_set(str,aptr);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X break;
X /* float and double added gnb@melba.bby.oz.au 22/11/89 */
X case 'f':
X case 'F':
X along = (strend - s) / sizeof(float);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s, (char *)&afloat, sizeof(float));
X s += sizeof(float);
X cdouble += afloat;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s, (char *)&afloat, sizeof(float));
X s += sizeof(float);
X str = Str_new(47, 0);
X str_numset(str, (double)afloat);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'd':
X case 'D':
X along = (strend - s) / sizeof(double);
X if (len > along)
X len = along;
X if (checksum) {
X while (len-- > 0) {
X bcopy(s, (char *)&adouble, sizeof(double));
X s += sizeof(double);
X cdouble += adouble;
X }
X }
X else {
X while (len-- > 0) {
X bcopy(s, (char *)&adouble, sizeof(double));
X s += sizeof(double);
X str = Str_new(48, 0);
X str_numset(str, (double)adouble);
X (void)astore(stack, ++sp, str_2mortal(str));
X }
X }
X break;
X case 'u':
X along = (strend - s) * 3 / 4;
X str = Str_new(42,along);
X while (s < strend && *s > ' ' && *s < 'a') {
X int a,b,c,d;
X char hunk[4];
X
X hunk[3] = '\0';
X len = (*s++ - ' ') & 077;
X while (len > 0) {
X if (s < strend && *s >= ' ')
X a = (*s++ - ' ') & 077;
X else
X a = 0;
X if (s < strend && *s >= ' ')
X b = (*s++ - ' ') & 077;
X else
X b = 0;
X if (s < strend && *s >= ' ')
X c = (*s++ - ' ') & 077;
X else
X c = 0;
X if (s < strend && *s >= ' ')
X d = (*s++ - ' ') & 077;
X else
X d = 0;
X hunk[0] = a << 2 | b >> 4;
X hunk[1] = b << 4 | c >> 2;
X hunk[2] = c << 6 | d;
X str_ncat(str,hunk, len > 3 ? 3 : len);
X len -= 3;
X }
X if (*s == '\n')
X s++;
X else if (s[1] == '\n') /* possible checksum byte */
X s += 2;
X }
X (void)astore(stack, ++sp, str_2mortal(str));
X break;
X }
X if (checksum) {
X str = Str_new(42,0);
X if (index("fFdD", datumtype) ||
X (checksum > 32 && index("iIlLN", datumtype)) ) {
X double modf();
X double trouble;
X
X adouble = 1.0;
X while (checksum >= 16) {
X checksum -= 16;
X adouble *= 65536.0;
X }
X while (checksum >= 4) {
X checksum -= 4;
X adouble *= 16.0;
X }
X while (checksum--)
X adouble *= 2.0;
X along = (1 << checksum) - 1;
X while (cdouble < 0.0)
X cdouble += adouble;
X cdouble = modf(cdouble / adouble, &trouble) * adouble;
X str_numset(str,cdouble);
X }
X else {
X if (checksum < 32) {
X along = (1 << checksum) - 1;
X culong &= (unsigned long)along;
X }
X str_numset(str,(double)culong);
X }
X (void)astore(stack, ++sp, str_2mortal(str));
X checksum = 0;
X }
X }
X return sp;
X}
X
Xint
Xdo_slice(stab,str,numarray,lval,gimme,arglast)
XSTAB *stab;
XSTR *str;
Xint numarray;
Xint lval;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int max = arglast[2];
X register char *tmps;
X register int len;
X register int magic = 0;
X register ARRAY *ary;
X register HASH *hash;
X int oldarybase = arybase;
X
X if (numarray) {
X if (numarray == 2) { /* a slice of a LIST */
X ary = stack;
X ary->ary_fill = arglast[3];
X arybase -= max + 1;
X st[sp] = str; /* make stack size available */
X str_numset(str,(double)(sp - 1));
X }
X else
X ary = stab_array(stab); /* a slice of an array */
X }
X else {
X if (lval) {
X if (stab == envstab)
X magic = 'E';
X else if (stab == sigstab)
X magic = 'S';
X#ifdef SOME_DBM
X else if (stab_hash(stab)->tbl_dbm)
X magic = 'D';
X#endif /* SOME_DBM */
X }
X hash = stab_hash(stab); /* a slice of an associative array */
X }
X
X if (gimme == G_ARRAY) {
X if (numarray) {
X while (sp < max) {
X if (st[++sp]) {
X st[sp-1] = afetch(ary,
X ((int)str_gnum(st[sp])) - arybase, lval);
X }
X else
X st[sp-1] = &str_undef;
X }
X }
X else {
X while (sp < max) {
X if (st[++sp]) {
X tmps = str_get(st[sp]);
X len = st[sp]->str_cur;
X st[sp-1] = hfetch(hash,tmps,len, lval);
X if (magic)
X str_magic(st[sp-1],stab,magic,tmps,len);
X }
X else
X st[sp-1] = &str_undef;
X }
X }
X sp--;
X }
X else {
X if (numarray) {
X if (st[max])
X st[sp] = afetch(ary,
X ((int)str_gnum(st[max])) - arybase, lval);
X else
X st[sp] = &str_undef;
X }
X else {
X if (st[max]) {
X tmps = str_get(st[max]);
X len = st[max]->str_cur;
X st[sp] = hfetch(hash,tmps,len, lval);
X if (magic)
X str_magic(st[sp],stab,magic,tmps,len);
X }
X else
X st[sp] = &str_undef;
X }
X }
X arybase = oldarybase;
X return sp;
X}
X
Xint
Xdo_splice(ary,gimme,arglast)
Xregister ARRAY *ary;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X int max = arglast[2] + 1;
X register STR **src;
X register STR **dst;
X register int i;
X register int offset;
X register int length;
X int newlen;
X int after;
X int diff;
X STR **tmparyval;
X
X if (++sp < max) {
X offset = ((int)str_gnum(st[sp])) - arybase;
X if (offset < 0)
X offset += ary->ary_fill + 1;
X if (++sp < max) {
X length = (int)str_gnum(st[sp++]);
X if (length < 0)
X length = 0;
X }
X else
X length = ary->ary_max; /* close enough to infinity */
X }
X else {
X offset = 0;
X length = ary->ary_max;
X }
X if (offset < 0) {
X length += offset;
X offset = 0;
X if (length < 0)
X length = 0;
X }
X if (offset > ary->ary_fill + 1)
X offset = ary->ary_fill + 1;
X after = ary->ary_fill + 1 - (offset + length);
X if (after < 0) { /* not that much array */
X length += after; /* offset+length now in array */
X after = 0;
X if (!ary->ary_alloc) {
X afill(ary,0);
X afill(ary,-1);
X }
X }
X
X /* At this point, sp .. max-1 is our new LIST */
X
X newlen = max - sp;
X diff = newlen - length;
X
X if (diff < 0) { /* shrinking the area */
X if (newlen) {
X New(451, tmparyval, newlen, STR*); /* so remember insertion */
X Copy(st+sp, tmparyval, newlen, STR*);
X }
X
X sp = arglast[0] + 1;
X if (gimme == G_ARRAY) { /* copy return vals to stack */
X if (sp + length >= stack->ary_max) {
X astore(stack,sp + length, Nullstr);
X st = stack->ary_array;
X }
X Copy(ary->ary_array+offset, st+sp, length, STR*);
X if (ary->ary_flags & ARF_REAL) {
X for (i = length, dst = st+sp; i; i--)
X str_2mortal(*dst++); /* free them eventualy */
X }
X sp += length - 1;
X }
X else {
X st[sp] = ary->ary_array[offset+length-1];
X if (ary->ary_flags & ARF_REAL)
X str_2mortal(st[sp]);
X }
X ary->ary_fill += diff;
X
X /* pull up or down? */
X
X if (offset < after) { /* easier to pull up */
X if (offset) { /* esp. if nothing to pull */
X src = &ary->ary_array[offset-1];
X dst = src - diff; /* diff is negative */
X for (i = offset; i > 0; i--) /* can't trust Copy */
X *dst-- = *src--;
X }
X Zero(ary->ary_array, -diff, STR*);
X ary->ary_array -= diff; /* diff is negative */
X ary->ary_max += diff;
X }
X else {
X if (after) { /* anything to pull down? */
X src = ary->ary_array + offset + length;
X dst = src + diff; /* diff is negative */
X Copy(src, dst, after, STR*);
X }
X Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
X /* avoid later double free */
X }
X if (newlen) {
X for (src = tmparyval, dst = ary->ary_array + offset;
X newlen; newlen--) {
X *dst = Str_new(46,0);
X str_sset(*dst++,*src++);
X }
X Safefree(tmparyval);
X }
X }
X else { /* no, expanding (or same) */
X if (length) {
X New(452, tmparyval, length, STR*); /* so remember deletion */
X Copy(ary->ary_array+offset, tmparyval, length, STR*);
X }
X
X if (diff > 0) { /* expanding */
X
X /* push up or down? */
X
X if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
X if (offset) {
X src = ary->ary_array;
X dst = src - diff;
X Copy(src, dst, offset, STR*);
X }
X ary->ary_array -= diff; /* diff is positive */
X ary->ary_max += diff;
X ary->ary_fill += diff;
X }
X else {
X if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */
X astore(ary, ary->ary_fill + diff, Nullstr);
X else
X ary->ary_fill += diff;
X if (after) {
X dst = ary->ary_array + ary->ary_fill;
X src = dst - diff;
X for (i = after; i; i--) {
X if (*dst) /* str was hanging around */
X str_free(*dst); /* after $#foo */
X *dst-- = *src;
X *src-- = Nullstr;
X }
X }
X }
X }
X
X for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
X *dst = Str_new(46,0);
X str_sset(*dst++,*src++);
X }
X sp = arglast[0] + 1;
X if (gimme == G_ARRAY) { /* copy return vals to stack */
X if (length) {
X Copy(tmparyval, st+sp, length, STR*);
X if (ary->ary_flags & ARF_REAL) {
X for (i = length, dst = st+sp; i; i--)
X str_2mortal(*dst++); /* free them eventualy */
X }
X Safefree(tmparyval);
X }
X sp += length - 1;
X }
X else if (length) {
X st[sp] = tmparyval[length-1];
X if (ary->ary_flags & ARF_REAL)
X str_2mortal(st[sp]);
X Safefree(tmparyval);
X }
X else
X st[sp] = &str_undef;
X }
X return sp;
X}
X
Xint
Xdo_grep(arg,str,gimme,arglast)
Xregister ARG *arg;
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int dst = arglast[1];
X register int src = dst + 1;
X register int sp = arglast[2];
X register int i = sp - arglast[1];
X int oldsave = savestack->ary_fill;
X SPAT *oldspat = curspat;
X int oldtmps_base = tmps_base;
X
X savesptr(&stab_val(defstab));
X tmps_base = tmps_max;
X if ((arg[1].arg_type & A_MASK) != A_EXPR) {
X arg[1].arg_type &= A_MASK;
X dehoist(arg,1);
X arg[1].arg_type |= A_DONT;
X }
X arg = arg[1].arg_ptr.arg_arg;
X while (i-- > 0) {
X if (st[src])
X stab_val(defstab) = st[src];
X else
X stab_val(defstab) = str_mortal(&str_undef);
X (void)eval(arg,G_SCALAR,sp);
X st = stack->ary_array;
X if (str_true(st[sp+1]))
X st[dst++] = st[src];
X src++;
X curspat = oldspat;
X }
X restorelist(oldsave);
X tmps_base = oldtmps_base;
X if (gimme != G_ARRAY) {
X str_numset(str,(double)(dst - arglast[1]));
X STABSET(str);
X st[arglast[0]+1] = str;
X return arglast[0]+1;
X }
X return arglast[0] + (dst - arglast[1]);
X}
X
Xint
Xdo_reverse(arglast)
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register STR **up = &st[arglast[1]];
X register STR **down = &st[arglast[2]];
X register int i = arglast[2] - arglast[1];
X
X while (i-- > 0) {
X *up++ = *down;
X if (i-- > 0)
X *down-- = *up;
X }
X i = arglast[2] - arglast[1];
X Copy(down+1,up,i/2,STR*);
X return arglast[2] - 1;
X}
X
Xint
Xdo_sreverse(str,arglast)
XSTR *str;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register char *up;
X register char *down;
X register int tmp;
X
X str_sset(str,st[arglast[2]]);
X up = str_get(str);
X if (str->str_cur > 1) {
X down = str->str_ptr + str->str_cur - 1;
X while (down > up) {
X tmp = *up;
X *up++ = *down;
X *down-- = tmp;
X }
X }
X STABSET(str);
X st[arglast[0]+1] = str;
X return arglast[0]+1;
X}
X
Xstatic CMD *sortcmd;
Xstatic HASH *sortstash = Null(HASH*);
Xstatic STAB *firststab = Nullstab;
Xstatic STAB *secondstab = Nullstab;
X
Xint
Xdo_sort(str,stab,gimme,arglast)
XSTR *str;
XSTAB *stab;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X int sp = arglast[1];
X register STR **up;
X register int max = arglast[2] - sp;
X register int i;
X int sortcmp();
X int sortsub();
X STR *oldfirst;
X STR *oldsecond;
X ARRAY *oldstack;
X static ARRAY *sortstack = Null(ARRAY*);
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X up = &st[sp];
X st += sp; /* temporarily make st point to args */
X for (i = 1; i <= max; i++) {
X if (*up = st[i]) {
X if (!(*up)->str_pok)
X (void)str_2ptr(*up);
X else
X (*up)->str_pok &= ~SP_TEMP;
X up++;
X }
X }
X st -= sp;
X max = up - &st[sp];
X sp--;
X if (max > 1) {
X if (stab) {
X int oldtmps_base = tmps_base;
X
X if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
X fatal("Undefined subroutine \"%s\" in sort", stab_name(stab));
X if (!sortstack) {
X sortstack = anew(Nullstab);
X astore(sortstack, 0, Nullstr);
X aclear(sortstack);
X sortstack->ary_flags = 0;
X }
X oldstack = stack;
X stack = sortstack;
X tmps_base = tmps_max;
X if (sortstash != stab_stash(stab)) {
X firststab = stabent("a",TRUE);
X secondstab = stabent("b",TRUE);
X sortstash = stab_stash(stab);
X }
X oldfirst = stab_val(firststab);
X oldsecond = stab_val(secondstab);
X#ifndef lint
X qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
X#else
X qsort(Nullch,max,sizeof(STR*),sortsub);
X#endif
X stab_val(firststab) = oldfirst;
X stab_val(secondstab) = oldsecond;
X tmps_base = oldtmps_base;
X stack = oldstack;
X }
X#ifndef lint
X else
X qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
X#endif
X }
X return sp+max;
X}
X
Xint
Xsortsub(str1,str2)
XSTR **str1;
XSTR **str2;
X{
X stab_val(firststab) = *str1;
X stab_val(secondstab) = *str2;
X cmd_exec(sortcmd,G_SCALAR,-1);
X return (int)str_gnum(*stack->ary_array);
X}
X
Xsortcmp(strp1,strp2)
XSTR **strp1;
XSTR **strp2;
X{
X register STR *str1 = *strp1;
X register STR *str2 = *strp2;
X int retval;
X
X if (str1->str_cur < str2->str_cur) {
X if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
X return retval;
X else
X return -1;
X }
X else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
X return retval;
X else if (str1->str_cur == str2->str_cur)
X return 0;
X else
X return 1;
X}
X
Xint
Xdo_range(gimme,arglast)
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X register int i;
X register ARRAY *ary = stack;
X register STR *str;
X int max;
X
X if (gimme != G_ARRAY)
X fatal("panic: do_range");
X
X if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
X (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
X i = (int)str_gnum(st[sp+1]);
X max = (int)str_gnum(st[sp+2]);
X while (i <= max) {
X (void)astore(ary, ++sp, str = str_mortal(&str_no));
X str_numset(str,(double)i++);
X }
X }
X else {
X STR *final = str_mortal(st[sp+2]);
X char *tmps = str_get(final);
X
X str = str_mortal(st[sp+1]);
X while (!str->str_nok && str->str_cur <= final->str_cur &&
X strNE(str->str_ptr,tmps) ) {
X (void)astore(ary, ++sp, str);
X str = str_2mortal(str_smake(str));
X str_inc(str);
X }
X if (strEQ(str->str_ptr,tmps))
X (void)astore(ary, ++sp, str);
X }
X return sp;
X}
X
Xint
Xdo_repeatary(arglast)
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X register int items = arglast[1] - sp;
X register int count = (int) str_gnum(st[arglast[2]]);
X register ARRAY *ary = stack;
X register int i;
X int max;
X
X max = items * count;
X if (max > 0 && sp + max > stack->ary_max) {
X astore(stack, sp + max, Nullstr);
X st = stack->ary_array;
X }
X if (count > 1) {
X for (i = arglast[1]; i > sp; i--)
X st[i]->str_pok &= ~SP_TEMP;
X repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
X items * sizeof(STR*), count);
X }
X sp += max;
X
X return sp;
X}
X
Xint
Xdo_caller(arg,maxarg,gimme,arglast)
XARG *arg;
Xint maxarg;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X register CSV *csv = curcsv;
X STR *str;
X int count = 0;
X
X if (!csv)
X fatal("There is no caller");
X if (maxarg)
X count = (int) str_gnum(st[sp+1]);
X for (;;) {
X if (!csv)
X return sp;
X if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
X count++;
X if (!count--)
X break;
X csv = csv->curcsv;
X }
X if (gimme != G_ARRAY) {
X STR *str = arg->arg_ptr.arg_str;
X str_set(str,csv->curcmd->c_stash->tbl_name);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X
X#ifndef lint
X (void)astore(stack,++sp,
X str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
X (void)astore(stack,++sp,
X str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
X (void)astore(stack,++sp,
X str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
X if (!maxarg)
X return sp;
X str = Str_new(49,0);
X stab_fullname(str, csv->stab);
X (void)astore(stack,++sp, str_2mortal(str));
X (void)astore(stack,++sp,
X str_2mortal(str_nmake((double)csv->hasargs)) );
X (void)astore(stack,++sp,
X str_2mortal(str_nmake((double)csv->wantarray)) );
X if (csv->hasargs) {
X ARRAY *ary = csv->argarray;
X
X if (dbargs->ary_max < ary->ary_fill)
X astore(dbargs,ary->ary_fill,Nullstr);
X Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
X dbargs->ary_fill = ary->ary_fill;
X }
X#else
X (void)astore(stack,++sp,
X str_2mortal(str_make("",0)));
X#endif
X return sp;
X}
X
Xint
Xdo_tms(str,gimme,arglast)
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X#ifdef MSDOS
X return -1;
X#else
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)times(×buf);
X
X#ifndef HZ
X#define HZ 60
X#endif
X
X#ifndef lint
X (void)astore(stack,++sp,
X str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
X (void)astore(stack,++sp,
X str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
X (void)astore(stack,++sp,
X str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
X (void)astore(stack,++sp,
X str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
X#else
X (void)astore(stack,++sp,
X str_2mortal(str_nmake(0.0)));
X#endif
X return sp;
X#endif
X}
X
Xint
Xdo_time(str,tmbuf,gimme,arglast)
XSTR *str;
Xstruct tm *tmbuf;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0];
X
X if (!tmbuf || gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
X (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
X return sp;
X}
X
Xint
Xdo_kv(str,hash,kv,gimme,arglast)
XSTR *str;
XHASH *hash;
Xint kv;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0];
X int i;
X register HENT *entry;
X char *tmps;
X STR *tmpstr;
X int dokeys = (kv == O_KEYS || kv == O_HASH);
X int dovalues = (kv == O_VALUES || kv == O_HASH);
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)hiterinit(hash);
X while (entry = hiternext(hash)) {
X if (dokeys) {
X tmps = hiterkey(entry,&i);
X if (!i)
X tmps = "";
X (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
X }
X if (dovalues) {
X tmpstr = Str_new(45,0);
X#ifdef DEBUGGING
X if (debug & 8192) {
X sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
X hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
X str_set(tmpstr,buf);
X }
X else
X#endif
X str_sset(tmpstr,hiterval(hash,entry));
X (void)astore(ary,++sp,str_2mortal(tmpstr));
X }
X }
X return sp;
X}
X
Xint
Xdo_each(str,hash,gimme,arglast)
XSTR *str;
XHASH *hash;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X static STR *mystrk = Nullstr;
X HENT *entry = hiternext(hash);
X int i;
X char *tmps;
X
X if (mystrk) {
X str_free(mystrk);
X mystrk = Nullstr;
X }
X
X if (entry) {
X if (gimme == G_ARRAY) {
X tmps = hiterkey(entry, &i);
X if (!i)
X tmps = "";
X st[++sp] = mystrk = str_make(tmps,i);
X }
X st[++sp] = str;
X str_sset(str,hiterval(hash,entry));
X STABSET(str);
X return sp;
X }
X else
X return sp;
X}
!STUFFY!FUNK!
echo Extracting h2ph.SH
sed >h2ph.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase $CONFIG in
X'')
X if test ! -f config.sh; then
X ln ../config.sh . || \
X ln ../../config.sh . || \
X ln ../../../config.sh . || \
X (echo "Can't find config.sh."; exit 1)
X fi 2>/dev/null
X . ./config.sh
X ;;
Xesac
X: This forces SH files to create target in same directory as SH file.
X: This is so that make depend always knows where to find SH derivatives.
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xecho "Extracting h2ph (with variable substitutions)"
X: This section of the file will have variable substitutions done on it.
X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
X: Protect any dollar signs and backticks that you do not want interpreted
X: by putting a backslash in front. You may delete these comments.
X$spitshell >h2ph <<!GROK!THIS!
X#!$bin/perl
X'di';
X'ig00';
X
X\$perlincl = '$privlib';
X!GROK!THIS!
X
X: In the following dollars and backticks do not need the extra backslash.
X$spitshell >>h2ph <<'!NO!SUBS!'
X
Xchdir '/usr/include' || die "Can't cd /usr/include";
X
X@isatype = split(' ',<<END);
X char uchar u_char
X short ushort u_short
X int uint u_int
X long ulong u_long
X FILE
XEND
X
X$isatype{@isatype} = (1) x @isatype;
X
X@ARGV = ('-') unless @ARGV;
X
Xforeach $file (@ARGV) {
X if ($file eq '-') {
X open(IN, "-");
X open(OUT, ">-");
X }
X else {
X ($outfile = $file) =~ s/\.h$/.ph/ || next;
X print "$file -> $outfile\n";
X if ($file =~ m|^(.*)/|) {
X $dir = $1;
X if (!-d "$perlincl/$dir") {
X mkdir("$perlincl/$dir",0777);
X }
X }
X open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
X open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
X }
X while (<IN>) {
X chop;
X while (/\\$/) {
X chop;
X $_ .= <IN>;
X chop;
X }
X if (s:/\*:\200:g) {
X s:\*/:\201:g;
X s/\200[^\201]*\201//g; # delete single line comments
X if (s/\200.*//) { # begin multi-line comment?
X $_ .= '/*';
X $_ .= <IN>;
X redo;
X }
X }
X if (s/^#\s*//) {
X if (s/^define\s+(\w+)//) {
X $name = $1;
X $new = '';
X s/\s+$//;
X if (s/^\(([\w,\s]*)\)//) {
X $args = $1;
X if ($args ne '') {
X foreach $arg (split(/,\s*/,$args)) {
X $curargs{$arg} = 1;
X }
X $args =~ s/\b(\w)/\$$1/g;
X $args = "local($args) = \@_;\n$t ";
X }
X s/^\s+//;
X do expr();
X $new =~ s/(["\\])/\\$1/g;
X if ($t ne '') {
X $new =~ s/(['\\])/\\$1/g;
X print OUT $t,
X "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
X }
X else {
X print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
X }
X %curargs = ();
X }
X else {
X s/^\s+//;
X do expr();
X $new = 1 if $new eq '';
X if ($t ne '') {
X $new =~ s/(['\\])/\\$1/g;
X print OUT $t,"eval 'sub $name {",$new,";}';\n";
X }
X else {
X print OUT $t,"sub $name {",$new,";}\n";
X }
X }
X }
X elsif (/^include <(.*)>/) {
X ($incl = $1) =~ s/\.h$/.ph/;
X print OUT $t,"require '$incl';\n";
X }
X elsif (/^ifdef\s+(\w+)/) {
X print OUT $t,"if (defined &$1) {\n";
X $tab += 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X }
X elsif (/^ifndef\s+(\w+)/) {
X print OUT $t,"if (!defined &$1) {\n";
X $tab += 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X }
X elsif (s/^if\s+//) {
X $new = '';
X do expr();
X print OUT $t,"if ($new) {\n";
X $tab += 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X }
X elsif (s/^elif\s+//) {
X $new = '';
X do expr();
X $tab -= 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X print OUT $t,"}\n${t}elsif ($new) {\n";
X $tab += 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X }
X elsif (/^else/) {
X $tab -= 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X print OUT $t,"}\n${t}else {\n";
X $tab += 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X }
X elsif (/^endif/) {
X $tab -= 4;
X $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
X print OUT $t,"}\n";
X }
X }
X }
X print OUT "1;\n";
X}
X
Xsub expr {
X while ($_ ne '') {
X s/^(\s+)// && do {$new .= ' '; next;};
X s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
X s/^(\d+)// && do {$new .= $1; next;};
X s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
X s/^'((\\"|[^"])*)'// && do {
X if ($curargs{$1}) {
X $new .= "ord('\$$1')";
X }
X else {
X $new .= "ord('$1')";
X }
X next;
X };
X s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
X $new .= '$sizeof';
X next;
X };
X s/^([_a-zA-Z]\w*)// && do {
X $id = $1;
X if ($id eq 'struct') {
X s/^\s+(\w+)//;
X $id .= ' ' . $1;
X $isatype{$id} = 1;
X }
X elsif ($id eq 'unsigned') {
X s/^\s+(\w+)//;
X $id .= ' ' . $1;
X $isatype{$id} = 1;
X }
X if ($curargs{$id}) {
X $new .= '$' . $id;
X }
X elsif ($id eq 'defined') {
X $new .= 'defined';
X }
X elsif (/^\(/) {
X s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
X $new .= " &$id";
X }
X elsif ($isatype{$id}) {
X if ($new =~ /{\s*$/) {
X $new .= "'$id'";
X }
X elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
X $new =~ s/\(\s*$//;
X s/^[\s*]*\)//;
X }
X else {
X $new .= $id;
X }
X }
X else {
X $new .= ' &' . $id;
X }
X next;
X };
X s/^(.)// && do {$new .= $1; next;};
X }
X}
X##############################################################################
X
X # These next few lines are legal in both Perl and nroff.
X
X.00; # finish .ig
X
X'di \" finish diversion--previous line must be blank
X.nr nl 0-1 \" fake up transition to first page again
X.nr % 0 \" start at page 1
X'; __END__ ############# From here on it's a standard manual page ############
X.TH H2PH 1 "August 8, 1990"
X.AT 3
X.SH NAME
Xh2ph \- convert .h C header files to .ph Perl header files
X.SH SYNOPSIS
X.B h2ph [headerfiles]
X.SH DESCRIPTION
X.I h2ph
Xconverts any C header files specified to the corresponding Perl header file
Xformat.
XIt is most easily run while in /usr/include:
X.nf
X
X cd /usr/include; h2ph * sys/*
X
X.fi
XIf run with no arguments, filters standard input to standard output.
X.SH ENVIRONMENT
XNo environment variables are used.
X.SH FILES
X/usr/include/*.h
X.br
X/usr/include/sys/*.h
X.br
Xetc.
X.SH AUTHOR
XLarry Wall
X.SH "SEE ALSO"
Xperl(1)
X.SH DIAGNOSTICS
XThe usual warnings if it can't read or write the files involved.
X.SH BUGS
XDoesn't construct the %sizeof array for you.
X.PP
XIt doesn't handle all C constructs, but it does attempt to isolate
Xdefinitions inside evals so that you can get at the definitions
Xthat it can translate.
X.PP
XIt's only intended as a rough tool.
XYou may need to dicker with the files produced.
X.ex
X!NO!SUBS!
Xchmod 755 h2ph
X$eunicefix h2ph
Xrm -f h2ph.man
Xln h2ph h2ph.man
!STUFFY!FUNK!
echo " "
echo "End of kit 11 (of 36)"
cat /dev/null >kit11isdone
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: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.