Usenet 1994 October

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / perl3.0 / part19 < prev next >

Wrap

Internet Message Format | 1989-11-08 | 49.2 KB

From: rsalz@uunet.uu.net (Rich Salz) Newsgroups: comp.sources.unix Subject: v20i102: Perl, a language with features of C/sed/awk/shell/etc, Part19/24 Approved: rsalz@uunet.UU.NET Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> Posting-number: Volume 20, Issue 102 Archive-name: perl3.0/part19 #! /bin/sh # Make a new directory for the perl sources, cd to it, and run kits 1 # thru 24 through sh. When all 24 kits have been run, read README. echo "This is perl 3.0 kit 19 (of 24). If kit 19 is complete, the line" echo '"'"End of kit 19 (of 24)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir x2p 2>/dev/null echo Extracting malloc.c sed >malloc.c <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: malloc.c,v 3.0 89/10/18 15:20:39 lwall Locked $ X * X * $Log: malloc.c,v $ X * Revision 3.0 89/10/18 15:20:39 lwall X * 3.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 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#ifdef mips 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 Xchar * 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 if (*((int*)p) > 0x10000000) 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 nextf[bucket] = nextf[bucket]->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 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 Xchar * 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 x2p/str.c sed >x2p/str.c <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: str.c,v 3.0 89/10/18 15:35:18 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: str.c,v $ X * Revision 3.0 89/10/18 15:35:18 lwall X * 3.0 baseline X * X */ X X#include "handy.h" X#include "EXTERN.h" X#include "util.h" X#include "a2p.h" X Xstr_numset(str,num) Xregister STR *str; Xdouble num; X{ X str->str_nval = num; X str->str_pok = 0; /* invalidate pointer */ X str->str_nok = 1; /* validate number */ X} X Xchar * Xstr_2ptr(str) Xregister STR *str; X{ X register char *s; X X if (!str) X return ""; X GROWSTR(&(str->str_ptr), &(str->str_len), 24); X s = str->str_ptr; X if (str->str_nok) { X sprintf(s,"%.20g",str->str_nval); X while (*s) s++; X } X *s = '\0'; X str->str_cur = s - str->str_ptr; X str->str_pok = 1; X#ifdef DEBUGGING X if (debug & 32) X fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); X#endif X return str->str_ptr; X} X Xdouble Xstr_2num(str) Xregister STR *str; X{ X if (!str) X return 0.0; X if (str->str_len && str->str_pok) X str->str_nval = atof(str->str_ptr); X else X str->str_nval = 0.0; X str->str_nok = 1; X#ifdef DEBUGGING X if (debug & 32) X fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval); X#endif X return str->str_nval; X} X Xstr_sset(dstr,sstr) XSTR *dstr; Xregister STR *sstr; X{ X if (!sstr) X str_nset(dstr,No,0); X else if (sstr->str_nok) X str_numset(dstr,sstr->str_nval); X else if (sstr->str_pok) X str_nset(dstr,sstr->str_ptr,sstr->str_cur); X else X str_nset(dstr,"",0); X} X Xstr_nset(str,ptr,len) Xregister STR *str; Xregister char *ptr; Xregister int len; X{ X GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); X bcopy(ptr,str->str_ptr,len); X str->str_cur = len; X *(str->str_ptr+str->str_cur) = '\0'; X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X} X Xstr_set(str,ptr) Xregister STR *str; Xregister char *ptr; X{ X register int len; X X if (!ptr) X ptr = ""; X len = strlen(ptr); X GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); X bcopy(ptr,str->str_ptr,len+1); X str->str_cur = len; X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X} X Xstr_chop(str,ptr) /* like set but assuming ptr is in str */ Xregister STR *str; Xregister char *ptr; X{ X if (!(str->str_pok)) X str_2ptr(str); X str->str_cur -= (ptr - str->str_ptr); X bcopy(ptr,str->str_ptr, str->str_cur + 1); X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X} X Xstr_ncat(str,ptr,len) Xregister STR *str; Xregister char *ptr; Xregister int len; X{ X if (!(str->str_pok)) X str_2ptr(str); X GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); X bcopy(ptr,str->str_ptr+str->str_cur,len); X str->str_cur += len; X *(str->str_ptr+str->str_cur) = '\0'; X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X} X Xstr_scat(dstr,sstr) XSTR *dstr; Xregister STR *sstr; X{ X if (!(sstr->str_pok)) X str_2ptr(sstr); X if (sstr) X str_ncat(dstr,sstr->str_ptr,sstr->str_cur); X} X Xstr_cat(str,ptr) Xregister STR *str; Xregister char *ptr; X{ X register int len; X X if (!ptr) X return; X if (!(str->str_pok)) X str_2ptr(str); X len = strlen(ptr); X GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); X bcopy(ptr,str->str_ptr+str->str_cur,len+1); X str->str_cur += len; X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X} X Xchar * Xstr_append_till(str,from,delim,keeplist) Xregister STR *str; Xregister char *from; Xregister int delim; Xchar *keeplist; X{ X register char *to; X register int len; X X if (!from) X return Nullch; X len = strlen(from); X GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1); X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X to = str->str_ptr+str->str_cur; X for (; *from; from++,to++) { X if (*from == '\\' && from[1] && delim != '\\') { X if (!keeplist) { X if (from[1] == delim || from[1] == '\\') X from++; X else X *to++ = *from++; X } X else if (index(keeplist,from[1])) X *to++ = *from++; X else X from++; X } X else if (*from == delim) X break; X *to = *from; X } X *to = '\0'; X str->str_cur = to - str->str_ptr; X return from; X} X XSTR * Xstr_new(len) Xint len; X{ X register STR *str; X X if (freestrroot) { X str = freestrroot; X freestrroot = str->str_link.str_next; X } X else { X str = (STR *) safemalloc(sizeof(STR)); X bzero((char*)str,sizeof(STR)); X } X if (len) X GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); X return str; X} X Xvoid Xstr_grow(str,len) Xregister STR *str; Xint len; X{ X if (len && str) X GROWSTR(&(str->str_ptr), &(str->str_len), len + 1); X} X X/* make str point to what nstr did */ X Xvoid Xstr_replace(str,nstr) Xregister STR *str; Xregister STR *nstr; X{ X safefree(str->str_ptr); X str->str_ptr = nstr->str_ptr; X str->str_len = nstr->str_len; X str->str_cur = nstr->str_cur; X str->str_pok = nstr->str_pok; X if (str->str_nok = nstr->str_nok) X str->str_nval = nstr->str_nval; X safefree((char*)nstr); X} X Xvoid Xstr_free(str) Xregister STR *str; X{ X if (!str) X return; X if (str->str_len) X str->str_ptr[0] = '\0'; X str->str_cur = 0; X str->str_nok = 0; X str->str_pok = 0; X str->str_link.str_next = freestrroot; X freestrroot = str; X} X Xstr_len(str) Xregister STR *str; X{ X if (!str) X return 0; X if (!(str->str_pok)) X str_2ptr(str); X if (str->str_len) X return str->str_cur; X else X return 0; X} X Xchar * Xstr_gets(str,fp) Xregister STR *str; Xregister FILE *fp; X{ X#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ X X register char *bp; /* we're going to steal some values */ X register int cnt; /* from the stdio struct and put EVERYTHING */ X register STDCHAR *ptr; /* in the innermost loop into registers */ X register char newline = '\n'; /* (assuming at least 6 registers) */ X int i; X int bpx; X X cnt = fp->_cnt; /* get count into register */ X str->str_nok = 0; /* invalidate number */ X str->str_pok = 1; /* validate pointer */ X if (str->str_len <= cnt) /* make sure we have the room */ X GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1); X bp = str->str_ptr; /* move these two too to registers */ X ptr = fp->_ptr; X for (;;) { X while (--cnt >= 0) { X if ((*bp++ = *ptr++) == newline) X if (bp <= str->str_ptr || bp[-2] != '\\') X goto thats_all_folks; X else { X line++; X bp -= 2; X } X } X X fp->_cnt = cnt; /* deregisterize cnt and ptr */ X fp->_ptr = ptr; X i = _filbuf(fp); /* get more characters */ X cnt = fp->_cnt; X ptr = fp->_ptr; /* reregisterize cnt and ptr */ X X bpx = bp - str->str_ptr; /* prepare for possible relocation */ X GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1); X bp = str->str_ptr + bpx; /* reconstitute our pointer */ X X if (i == newline) { /* all done for now? */ X *bp++ = i; X goto thats_all_folks; X } X else if (i == EOF) /* all done for ever? */ X goto thats_all_folks; X *bp++ = i; /* now go back to screaming loop */ X } X Xthats_all_folks: X fp->_cnt = cnt; /* put these back or we're in trouble */ X fp->_ptr = ptr; X *bp = '\0'; X str->str_cur = bp - str->str_ptr; /* set length */ X X#else /* !STDSTDIO */ /* The big, slow, and stupid way */ X X static char buf[4192]; X X if (fgets(buf, sizeof buf, fp) != Nullch) X str_set(str, buf); X else X str_set(str, No); X X#endif /* STDSTDIO */ X X return str->str_cur ? str->str_ptr : Nullch; X} X Xvoid Xstr_inc(str) Xregister STR *str; X{ X register char *d; X X if (!str) X return; X if (str->str_nok) { X str->str_nval += 1.0; X str->str_pok = 0; X return; X } X if (!str->str_pok) { X str->str_nval = 1.0; X str->str_nok = 1; X return; X } X for (d = str->str_ptr; *d && *d != '.'; d++) ; X d--; X if (!isdigit(*str->str_ptr) || !isdigit(*d) ) { X str_numset(str,atof(str->str_ptr) + 1.0); /* punt */ X return; X } X while (d >= str->str_ptr) { X if (++*d <= '9') X return; X *(d--) = '0'; X } X /* oh,oh, the number grew */ X GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2); X str->str_cur++; X for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) X *d = d[-1]; X *d = '1'; X} X Xvoid Xstr_dec(str) Xregister STR *str; X{ X register char *d; X X if (!str) X return; X if (str->str_nok) { X str->str_nval -= 1.0; X str->str_pok = 0; X return; X } X if (!str->str_pok) { X str->str_nval = -1.0; X str->str_nok = 1; X return; X } X for (d = str->str_ptr; *d && *d != '.'; d++) ; X d--; X if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) { X str_numset(str,atof(str->str_ptr) - 1.0); /* punt */ X return; X } X while (d >= str->str_ptr) { X if (--*d >= '0') X return; X *(d--) = '9'; X } X} X X/* make a string that will exist for the duration of the expression eval */ X XSTR * Xstr_static(oldstr) XSTR *oldstr; X{ X register STR *str = str_new(0); X static long tmps_size = -1; X X str_sset(str,oldstr); X if (++tmps_max > tmps_size) { X tmps_size = tmps_max; X if (!(tmps_size & 127)) { X if (tmps_size) X tmps_list = (STR**)saferealloc((char*)tmps_list, X (tmps_size + 128) * sizeof(STR*) ); X else X tmps_list = (STR**)safemalloc(128 * sizeof(char*)); X } X } X tmps_list[tmps_max] = str; X return str; X} X XSTR * Xstr_make(s) Xchar *s; X{ X register STR *str = str_new(0); X X str_set(str,s); X return str; X} X XSTR * Xstr_nmake(n) Xdouble n; X{ X register STR *str = str_new(0); X X str_numset(str,n); X return str; X} !STUFFY!FUNK! echo Extracting x2p/a2p.y sed >x2p/a2p.y <<'!STUFFY!FUNK!' -e 's/X//' X%{ X/* $Header: a2p.y,v 3.0 89/10/18 15:34:29 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: a2p.y,v $ X * Revision 3.0 89/10/18 15:34:29 lwall X * 3.0 baseline X * X */ X X#include "INTERN.h" X#include "a2p.h" X Xint root; Xint begins = Nullop; Xint ends = Nullop; X X%} X%token BEGIN END X%token REGEX X%token SEMINEW NEWLINE COMMENT X%token FUN1 FUNN GRGR X%token PRINT PRINTF SPRINTF SPLIT X%token IF ELSE WHILE FOR IN X%token EXIT NEXT BREAK CONTINUE RET X%token GETLINE DO SUB GSUB MATCH X%token FUNCTION USERFUN DELETE X X%right ASGNOP X%right '?' ':' X%left OROR X%left ANDAND X%left IN X%left NUMBER VAR SUBSTR INDEX X%left MATCHOP X%left RELOP '<' '>' X%left OR X%left STRING X%left '+' '-' X%left '*' '/' '%' X%right UMINUS X%left NOT X%right '^' X%left INCR DECR X%left FIELD VFIELD X X%% X Xprogram : junk hunks X { root = oper4(OPROG,$1,begins,$2,ends); } X ; X Xbegin : BEGIN '{' maybe states '}' junk X { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE; X $$ = Nullop; } X ; X Xend : END '{' maybe states '}' X { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; } X | end NEWLINE X { $$ = $1; } X ; X Xhunks : hunks hunk junk X { $$ = oper3(OHUNKS,$1,$2,$3); } X | /* NULL */ X { $$ = Nullop; } X ; X Xhunk : patpat X { $$ = oper1(OHUNK,$1); need_entire = TRUE; } X | patpat '{' maybe states '}' X { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); } X | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}' X { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); } X | '{' maybe states '}' X { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); } X | begin X | end X ; X Xarg_list: expr_list X { $$ = rememberargs($$); } X ; X Xpatpat : pat X { $$ = oper1(OPAT,$1); } X | pat ',' pat X { $$ = oper2(ORANGE,$1,$3); } X ; X Xpat : match X | rel X | compound_pat X ; X Xcompound_pat X : '(' compound_pat ')' X { $$ = oper1(OPPAREN,$2); } X | pat ANDAND maybe pat X { $$ = oper3(OPANDAND,$1,$3,$4); } X | pat OROR maybe pat X { $$ = oper3(OPOROR,$1,$3,$4); } X | NOT pat X { $$ = oper1(OPNOT,$2); } X ; X Xcond : expr X | match X | rel X | compound_cond X ; X Xcompound_cond X : '(' compound_cond ')' X { $$ = oper1(OCPAREN,$2); } X | cond ANDAND maybe cond X { $$ = oper3(OCANDAND,$1,$3,$4); } X | cond OROR maybe cond X { $$ = oper3(OCOROR,$1,$3,$4); } X | NOT cond X { $$ = oper1(OCNOT,$2); } X ; X Xrel : expr RELOP expr X { $$ = oper3(ORELOP,$2,$1,$3); } X | expr '>' expr X { $$ = oper3(ORELOP,string(">",1),$1,$3); } X | expr '<' expr X { $$ = oper3(ORELOP,string("<",1),$1,$3); } X | '(' rel ')' X { $$ = oper1(ORPAREN,$2); } X ; X Xmatch : expr MATCHOP expr X { $$ = oper3(OMATCHOP,$2,$1,$3); } X | expr MATCHOP REGEX X { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); } X | REGEX %prec MATCHOP X { $$ = oper1(OREGEX,$1); } X | '(' match ')' X { $$ = oper1(OMPAREN,$2); } X ; X Xexpr : term X { $$ = $1; } X | expr term X { $$ = oper2(OCONCAT,$1,$2); } X | variable ASGNOP expr X { $$ = oper3(OASSIGN,$2,$1,$3); X if ((ops[$1].ival & 255) == OFLD) X lval_field = TRUE; X if ((ops[$1].ival & 255) == OVFLD) X lval_field = TRUE; X } X ; X Xterm : variable X { $$ = $1; } X | NUMBER X { $$ = oper1(ONUM,$1); } X | STRING X { $$ = oper1(OSTR,$1); } X | term '+' term X { $$ = oper2(OADD,$1,$3); } X | term '-' term X { $$ = oper2(OSUBTRACT,$1,$3); } X | term '*' term X { $$ = oper2(OMULT,$1,$3); } X | term '/' term X { $$ = oper2(ODIV,$1,$3); } X | term '%' term X { $$ = oper2(OMOD,$1,$3); } X | term '^' term X { $$ = oper2(OPOW,$1,$3); } X | term IN VAR X { $$ = oper2(ODEFINED,aryrefarg($3),$1); } X | term '?' term ':' term X { $$ = oper2(OCOND,$1,$3,$5); } X | variable INCR X { $$ = oper1(OPOSTINCR,$1); } X | variable DECR X { $$ = oper1(OPOSTDECR,$1); } X | INCR variable X { $$ = oper1(OPREINCR,$2); } X | DECR variable X { $$ = oper1(OPREDECR,$2); } X | '-' term %prec UMINUS X { $$ = oper1(OUMINUS,$2); } X | '+' term %prec UMINUS X { $$ = oper1(OUPLUS,$2); } X | '(' expr ')' X { $$ = oper1(OPAREN,$2); } X | GETLINE X { $$ = oper0(OGETLINE); } X | GETLINE VAR X { $$ = oper1(OGETLINE,$2); } X | GETLINE '<' expr X { $$ = oper3(OGETLINE,Nullop,string("<",1),$3); X if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | GETLINE VAR '<' expr X { $$ = oper3(OGETLINE,$2,string("<",1),$4); X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | term 'p' GETLINE X { $$ = oper3(OGETLINE,Nullop,string("|",1),$1); X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | term 'p' GETLINE VAR X { $$ = oper3(OGETLINE,$4,string("|",1),$1); X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | FUN1 X { $$ = oper0($1); need_entire = do_chop = TRUE; } X | FUN1 '(' ')' X { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; } X | FUN1 '(' expr ')' X { $$ = oper1($1,$3); } X | FUNN '(' expr_list ')' X { $$ = oper1($1,$3); } X | USERFUN '(' expr_list ')' X { $$ = oper2(OUSERFUN,$1,$3); } X | SPRINTF expr_list X { $$ = oper1(OSPRINTF,$2); } X | SUBSTR '(' expr ',' expr ',' expr ')' X { $$ = oper3(OSUBSTR,$3,$5,$7); } X | SUBSTR '(' expr ',' expr ')' X { $$ = oper2(OSUBSTR,$3,$5); } X | SPLIT '(' expr ',' VAR ',' expr ')' X { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); } X | SPLIT '(' expr ',' VAR ')' X { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); } X | INDEX '(' expr ',' expr ')' X { $$ = oper2(OINDEX,$3,$5); } X | MATCH '(' expr ',' REGEX ')' X { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); } X | MATCH '(' expr ',' expr ')' X { $$ = oper2(OMATCH,$3,$5); } X | SUB '(' expr ',' expr ')' X { $$ = oper2(OSUB,$3,$5); } X | SUB '(' REGEX ',' expr ')' X { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); } X | GSUB '(' expr ',' expr ')' X { $$ = oper2(OGSUB,$3,$5); } X | GSUB '(' REGEX ',' expr ')' X { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); } X | SUB '(' expr ',' expr ',' expr ')' X { $$ = oper3(OSUB,$3,$5,$7); } X | SUB '(' REGEX ',' expr ',' expr ')' X { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); } X | GSUB '(' expr ',' expr ',' expr ')' X { $$ = oper3(OGSUB,$3,$5,$7); } X | GSUB '(' REGEX ',' expr ',' expr ')' X { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); } X ; X Xvariable: VAR X { $$ = oper1(OVAR,$1); } X | VAR '[' expr_list ']' X { $$ = oper2(OVAR,aryrefarg($1),$3); } X | FIELD X { $$ = oper1(OFLD,$1); } X | VFIELD term X { $$ = oper1(OVFLD,$2); } X ; X Xexpr_list X : expr X | clist X | /* NULL */ X { $$ = Nullop; } X ; X Xclist : expr ',' maybe expr X { $$ = oper3(OCOMMA,$1,$3,$4); } X | clist ',' maybe expr X { $$ = oper3(OCOMMA,$1,$3,$4); } X | '(' clist ')' /* these parens are invisible */ X { $$ = $2; } X ; X Xjunk : junk hunksep X { $$ = oper2(OJUNK,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xhunksep : ';' X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } X | SEMINEW X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } X | NEWLINE X { $$ = oper0(ONEWLINE); } X | COMMENT X { $$ = oper1(OCOMMENT,$1); } X ; X Xmaybe : maybe nlstuff X { $$ = oper2(OJUNK,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xnlstuff : NEWLINE X { $$ = oper0(ONEWLINE); } X | COMMENT X { $$ = oper1(OCOMMENT,$1); } X ; X Xseparator X : ';' maybe X { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); } X | SEMINEW maybe X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); } X | NEWLINE maybe X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); } X | COMMENT maybe X { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); } X ; X Xstates : states statement X { $$ = oper2(OSTATES,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xstatement X : simple separator maybe X { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); } X | ';' maybe X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); } X | SEMINEW maybe X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); } X | compound X ; X Xsimpnull: simple X | /* NULL */ X { $$ = Nullop; } X ; X Xsimple X : expr X | PRINT expr_list redir expr X { $$ = oper3(OPRINT,$2,$3,$4); X do_opens = TRUE; X saw_ORS = saw_OFS = TRUE; X if (!$2) need_entire = TRUE; X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | PRINT expr_list X { $$ = oper1(OPRINT,$2); X if (!$2) need_entire = TRUE; X saw_ORS = saw_OFS = TRUE; X } X | PRINTF expr_list redir expr X { $$ = oper3(OPRINTF,$2,$3,$4); X do_opens = TRUE; X if (!$2) need_entire = TRUE; X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | PRINTF expr_list X { $$ = oper1(OPRINTF,$2); X if (!$2) need_entire = TRUE; X } X | BREAK X { $$ = oper0(OBREAK); } X | NEXT X { $$ = oper0(ONEXT); } X | EXIT X { $$ = oper0(OEXIT); } X | EXIT expr X { $$ = oper1(OEXIT,$2); } X | CONTINUE X { $$ = oper0(OCONTINUE); } X | RET X { $$ = oper0(ORETURN); } X | RET expr X { $$ = oper1(ORETURN,$2); } X | DELETE VAR '[' expr ']' X { $$ = oper2(ODELETE,aryrefarg($2),$4); } X ; X Xredir : '>' %prec FIELD X { $$ = oper1(OREDIR,$1); } X | GRGR X { $$ = oper1(OREDIR,string(">>",2)); } X | '|' X { $$ = oper1(OREDIR,string("|",1)); } X ; X Xcompound X : IF '(' cond ')' maybe statement X { $$ = oper2(OIF,$3,bl($6,$5)); } X | IF '(' cond ')' maybe statement ELSE maybe statement X { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); } X | WHILE '(' cond ')' maybe statement X { $$ = oper2(OWHILE,$3,bl($6,$5)); } X | DO maybe statement WHILE '(' cond ')' X { $$ = oper2(ODO,bl($3,$2),$6); } X | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement X { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); } X | FOR '(' simpnull ';' ';' simpnull ')' maybe statement X { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); } X | FOR '(' expr ')' maybe statement X { $$ = oper2(OFORIN,$3,bl($6,$5)); } X | '{' maybe states '}' maybe X { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); } X ; X X%% X#include "a2py.c" !STUFFY!FUNK! echo Extracting Makefile.SH sed >Makefile.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 X . ./config.sh X ;; Xesac Xcase "$0" in X*/*) cd `expr X$0 : 'X$.*$/'` ;; Xesac X Xcase "$d_symlink" in X*define*) sln='ln -s' ;; X*) sln='ln';; Xesac X Xcase "$d_dosuid" in X*define*) suidperl='suidperl' ;; X*) suidperl='';; Xesac X Xecho "Extracting Makefile (with variable substitutions)" Xcat >Makefile <<!GROK!THIS! X# $Header: Makefile.SH,v 3.0 89/10/18 15:06:43 lwall Locked $ X# X# $Log: Makefile.SH,v $ X# Revision 3.0 89/10/18 15:06:43 lwall X# 3.0 baseline X# X XCC = $cc Xbin = $bin Xprivlib = $privlib Xmansrc = $mansrc Xmanext = $manext XCFLAGS = $ccflags $optimize $sockethdr XLDFLAGS = $ldflags XSMALL = $small XLARGE = $large $split Xmallocsrc = $mallocsrc Xmallocobj = $mallocobj XSLN = $sln X Xlibs = $libnm -lm $libdbm $libs $libndir $socketlib X Xpublic = perl taintperl $suidperl X X!GROK!THIS! X Xcat >>Makefile <<'!NO!SUBS!' Xprivate = X XMAKE = make X Xmanpages = perl.man X Xutil = X Xsh = Makefile.SH makedepend.SH X Xh1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h Xh2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h X Xh = $(h1) $(h2) X Xc1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c Xc2 = eval.c form.c hash.c $(mallocsrc) perly.c regcomp.c regexec.c Xc3 = stab.c str.c toke.c util.c X Xc = $(c1) $(c2) $(c3) X Xobj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o Xobj2 = eval.o form.o hash.o $(mallocobj) perly.o regcomp.o regexec.o Xobj3 = stab.o str.o toke.o util.o X Xobj = $(obj1) $(obj2) $(obj3) X Xtobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o Xtobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o Xtobj3 = tstab.o tstr.o ttoke.o tutil.o X Xtobj = $(tobj1) $(tobj2) $(tobj3) X Xlintflags = -hbvxac X Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7 X X# grrr XSHELL = /bin/sh X X.c.o: X $(CC) -c $(CFLAGS) $(LARGE) $*.c X Xall: $(public) $(private) $(util) perl.man x2p/all X touch all X Xx2p/all: X cd x2p; $(MAKE) all X X# This is the standard version that contains no "taint" checks and is X# used for all scripts that aren't set-id or running under something set-id. X Xperl: perl.o $(obj) X $(CC) $(LARGE) $(LDFLAGS) $(obj) perl.o $(libs) -o perl X X# This version, if specified in Configure, does ONLY those scripts which need X# set-id emulation. Suidperl must be setuid root. It contains the "taint" X# checks as well as the special code to validate that the script in question X# has been invoked correctly. X Xsuidperl: tperl.o sperly.o $(tobj) X $(CC) $(LARGE) $(LDFLAGS) sperly.o $(tobj) tperl.o $(libs) -o suidperl X X# This version interprets scripts that are already set-id either via a wrapper X# or through the kernel allowing set-id scripts (bad idea). Taintperl must X# NOT be setuid to root or anything else. The only difference between it X# and normal perl is the presence of the "taint" checks. X Xtaintperl: tperl.o tperly.o $(tobj) X $(CC) $(LARGE) $(LDFLAGS) tperly.o $(tobj) tperl.o $(libs) -o taintperl X X# Replicating all this junk is yucky, but I don't see a portable way to fix it. X Xtperl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h \ X config.h stab.h X /bin/rm -f tperl.c X $(SLN) perl.c tperl.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperl.c X /bin/rm -f tperl.c X Xtperly.o: perly.c X /bin/rm -f tperly.c X $(SLN) perly.c tperly.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tperly.c X /bin/rm -f tperly.c X Xsperly.o: perly.c perl.h handy.h perly.h patchlevel.h X /bin/rm -f sperly.c X $(SLN) perly.c sperly.c X $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) $(LARGE) sperly.c X /bin/rm -f sperly.c X Xtarray.o: array.c X /bin/rm -f tarray.c X $(SLN) array.c tarray.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tarray.c X /bin/rm -f tarray.c X Xtcmd.o: cmd.c X /bin/rm -f tcmd.c X $(SLN) cmd.c tcmd.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcmd.c X /bin/rm -f tcmd.c X Xtcons.o: cons.c X /bin/rm -f tcons.c X $(SLN) cons.c tcons.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tcons.c X /bin/rm -f tcons.c X Xtconsarg.o: consarg.c X /bin/rm -f tconsarg.c X $(SLN) consarg.c tconsarg.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tconsarg.c X /bin/rm -f tconsarg.c X Xtdoarg.o: doarg.c X /bin/rm -f tdoarg.c X $(SLN) doarg.c tdoarg.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdoarg.c X /bin/rm -f tdoarg.c X Xtdoio.o: doio.c X /bin/rm -f tdoio.c X $(SLN) doio.c tdoio.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdoio.c X /bin/rm -f tdoio.c X Xtdolist.o: dolist.c X /bin/rm -f tdolist.c X $(SLN) dolist.c tdolist.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdolist.c X /bin/rm -f tdolist.c X Xtdump.o: dump.c X /bin/rm -f tdump.c X $(SLN) dump.c tdump.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tdump.c X /bin/rm -f tdump.c X Xteval.o: eval.c X /bin/rm -f teval.c X $(SLN) eval.c teval.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) teval.c X /bin/rm -f teval.c X Xtform.o: form.c X /bin/rm -f tform.c X $(SLN) form.c tform.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tform.c X /bin/rm -f tform.c X Xthash.o: hash.c X /bin/rm -f thash.c X $(SLN) hash.c thash.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) thash.c X /bin/rm -f thash.c X Xtregcomp.o: regcomp.c X /bin/rm -f tregcomp.c X $(SLN) regcomp.c tregcomp.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tregcomp.c X /bin/rm -f tregcomp.c X Xtregexec.o: regexec.c X /bin/rm -f tregexec.c X $(SLN) regexec.c tregexec.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tregexec.c X /bin/rm -f tregexec.c X Xtstab.o: stab.c X /bin/rm -f tstab.c X $(SLN) stab.c tstab.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstab.c X /bin/rm -f tstab.c X Xtstr.o: str.c X /bin/rm -f tstr.c X $(SLN) str.c tstr.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tstr.c X /bin/rm -f tstr.c X Xttoke.o: toke.c X /bin/rm -f ttoke.c X $(SLN) toke.c ttoke.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) ttoke.c X /bin/rm -f ttoke.c X Xtutil.o: util.c X /bin/rm -f tutil.c X $(SLN) util.c tutil.c X $(CC) -c -DTAINT $(CFLAGS) $(LARGE) tutil.c X /bin/rm -f tutil.c X Xperl.c perly.h: perl.y X @ echo Expect 25 shift/reduce errors... X yacc -d perl.y X mv y.tab.c perl.c X mv y.tab.h perly.h X Xperl.o: perl.c perly.h perl.h EXTERN.h regexp.h util.h INTERN.h handy.h \ X config.h arg.h stab.h X $(CC) -c $(CFLAGS) $(LARGE) perl.c X Xperl.man: perl.man.1 perl.man.2 perl.man.3 perl.man.4 patchlevel.h perl X ./perl -e '($$r,$$p)=$$]=~/(\d+\.\d+).*\n\D*(\d+)/;' \ X -e 'print ".ds RP Release $$r Patchlevel $$p\n";' >perl.man X cat perl.man.[1-4] >>perl.man X Xinstall: all X# won't work with csh X export PATH || exit 1 X - rm -f $(bin)/perl.old $(bin)/suidperl $(bin)/taintperl X - mv $(bin)/perl $(bin)/perl.old 2>/dev/null X - if test `pwd` != $(bin); then cp $(public) $(bin); fi X - cd $(bin); \ Xfor pub in $(public); do \ Xchmod +x `basename $$pub`; \ Xdone X - chmod 755 $(bin)/taintperl 2>/dev/null X!NO!SUBS! X Xcase "$d_dosuid" in X*define*) X cat >>Makefile <<'!NO!SUBS!' X - chmod 4711 $(bin)/suidperl 2>/dev/null X!NO!SUBS! X ;; Xesac X Xcat >>Makefile <<'!NO!SUBS!' X - test $(bin) = /usr/bin || rm -f /usr/bin/perl X - test $(bin) = /usr/bin || $(SLN) $(bin)/perl /usr/bin || cp $(bin)/perl /usr/bin X - sh ./makedir $(privlib) X - \ Xif test `pwd` != $(privlib); then \ Xcp $(private) lib/*.pl $(privlib); \ Xfi X# cd $(privlib); \ X#for priv in $(private); do \ X#chmod +x `basename $$priv`; \ X#done X - if test `pwd` != $(mansrc); then \ Xfor page in $(manpages); do \ Xcp $$page $(mansrc)/`basename $$page .man`.$(manext); \ Xdone; \ Xfi X cd x2p; $(MAKE) install X Xclean: X rm -f *.o all perl taintperl perl.man X cd x2p; $(MAKE) clean X Xrealclean: X cd x2p; $(MAKE) realclean X rm -f perl *.orig */*.orig *~ */*~ *.o core $(addedbyconf) perl.man X rm -f perl.c perly.h t/perl Makefile config.h makedepend makedir X rm -f x2p/Makefile X X# The following lint has practically everything turned on. Unfortunately, X# you have to wade through a lot of mumbo jumbo that can't be suppressed. X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message X# for that spot. X Xlint: perl.c $(c) X lint $(lintflags) $(defs) perl.c $(c) > perl.fuzz X Xdepend: makedepend X - test -f perly.h || cp /dev/null perly.h X ./makedepend X - test -s perly.h || /bin/rm -f perly.h X cd x2p; $(MAKE) depend X Xtest: perl X - chmod +x t/TEST t/base.* t/comp.* t/cmd.* t/io.* t/op.*; \ X cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST X Xclist: X echo $(c) | tr ' ' '\012' >.clist X Xhlist: X echo $(h) | tr ' ' '\012' >.hlist X Xshlist: X echo $(sh) | tr ' ' '\012' >.shlist X X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE Xperly.o $(obj): X @ echo "You haven't done a "'"make depend" yet!'; exit 1 Xmakedepend: makedepend.SH X /bin/sh makedepend.SH X!NO!SUBS! X$eunicefix Makefile Xcase `pwd` in X*SH) X $rm -f ../Makefile X ln Makefile ../Makefile X ;; Xesac !STUFFY!FUNK! echo Extracting evalargs.xc sed >evalargs.xc <<'!STUFFY!FUNK!' -e 's/X//' X/* This file is included by eval.c. It's separate from eval.c to keep X * kit sizes from getting too big. X */ X X/* $Header: evalargs.xc,v 3.0 89/10/18 15:17:16 lwall Locked $ X * X * $Log: evalargs.xc,v $ X * Revision 3.0 89/10/18 15:17:16 lwall X * 3.0 baseline X * X */ X X for (anum = 1; anum <= maxarg; anum++) { X argflags = arg[anum].arg_flags; X argtype = arg[anum].arg_type; X argptr = arg[anum].arg_ptr; X re_eval: X switch (argtype) { X default: X st[++sp] = &str_undef; X#ifdef DEBUGGING X tmps = "NULL"; X#endif X break; X case A_EXPR: X#ifdef DEBUGGING X if (debug & 8) { X tmps = "EXPR"; X deb("%d.EXPR =>\n",anum); X } X#endif X sp = eval(argptr.arg_arg, X (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp); X if (sp + (maxarg - anum) > stack->ary_max) X astore(stack, sp + (maxarg - anum), Nullstr); X st = stack->ary_array; /* possibly reallocated */ X break; X case A_CMD: X#ifdef DEBUGGING X if (debug & 8) { X tmps = "CMD"; X deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd); X } X#endif X sp = cmd_exec(argptr.arg_cmd, gimme, sp); X if (sp + (maxarg - anum) > stack->ary_max) X astore(stack, sp + (maxarg - anum), Nullstr); X st = stack->ary_array; /* possibly reallocated */ X break; X case A_LARYSTAB: X ++sp; X str = afetch(stab_array(argptr.arg_stab), X arg[anum].arg_len - arybase, TRUE); X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab), X arg[anum].arg_len); X tmps = buf; X } X#endif X goto do_crement; X case A_ARYSTAB: X st[++sp] = afetch(stab_array(argptr.arg_stab), X arg[anum].arg_len - arybase, FALSE); X if (!st[sp]) X st[sp] = &str_undef; X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab), X arg[anum].arg_len); X tmps = buf; X } X#endif X break; X case A_STAR: X st[++sp] = (STR*)argptr.arg_stab; X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab)); X tmps = buf; X } X#endif X break; X case A_LSTAR: X str = st[++sp] = (STR*)argptr.arg_stab; X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"LSTAR *%s",stab_name(argptr.arg_stab)); X tmps = buf; X } X#endif X break; X case A_STAB: X st[++sp] = STAB_STR(argptr.arg_stab); X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab)); X tmps = buf; X } X#endif X break; X case A_LEXPR: X#ifdef DEBUGGING X if (debug & 8) { X tmps = "LEXPR"; X deb("%d.LEXPR =>\n",anum); X } X#endif X if (argflags & AF_ARYOK) { X sp = eval(argptr.arg_arg, G_ARRAY, sp); X if (sp + (maxarg - anum) > stack->ary_max) X astore(stack, sp + (maxarg - anum), Nullstr); X st = stack->ary_array; /* possibly reallocated */ X } X else { X sp = eval(argptr.arg_arg, G_SCALAR, sp); X st = stack->ary_array; /* possibly reallocated */ X str = st[sp]; X goto do_crement; X } X break; X case A_LVAL: X#ifdef DEBUGGING X if (debug & 8) { X (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab)); X tmps = buf; X } X#endif X ++sp; X str = STAB_STR(argptr.arg_stab); X if (!str) X fatal("panic: A_LVAL"); X do_crement: X assigning = TRUE; X if (argflags & AF_PRE) { X if (argflags & AF_UP) X str_inc(str); X else X str_dec(str); X STABSET(str); X st[sp] = str; X str = arg->arg_ptr.arg_str; X } X else if (argflags & AF_POST) { X st[sp] = str_static(str); X if (argflags & AF_UP) X str_inc(str); X else X str_dec(str); X STABSET(str); X str = arg->arg_ptr.arg_str; X } X else X st[sp] = str; X break; X case A_LARYLEN: X ++sp; X stab = argptr.arg_stab; X str = stab_array(argptr.arg_stab)->ary_magic; X if (argflags & (AF_PRE|AF_POST)) X str_numset(str,(double)(stab_array(stab)->ary_fill+arybase)); X#ifdef DEBUGGING X tmps = "LARYLEN"; X#endif X if (!str) X fatal("panic: A_LEXPR"); X goto do_crement; X case A_ARYLEN: X stab = argptr.arg_stab; X st[++sp] = stab_array(stab)->ary_magic; X str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase)); X#ifdef DEBUGGING X tmps = "ARYLEN"; X#endif X break; X case A_SINGLE: X st[++sp] = argptr.arg_str; X#ifdef DEBUGGING X tmps = "SINGLE"; X#endif X break; X case A_DOUBLE: X (void) interp(str,argptr.arg_str,sp); X st = stack->ary_array; X st[++sp] = str; X#ifdef DEBUGGING X tmps = "DOUBLE"; X#endif X break; X case A_BACKTICK: X tmps = str_get(interp(str,argptr.arg_str,sp)); X st = stack->ary_array; X#ifdef TAINT X taintproper("Insecure dependency in ``"); X#endif X fp = mypopen(tmps,"r"); X str_set(str,""); X if (fp) { X while (str_gets(str,fp,str->str_cur) != Nullch) X ; X statusvalue = mypclose(fp); X } X else X statusvalue = -1; X X st[++sp] = str; X#ifdef DEBUGGING X tmps = "BACK"; X#endif X break; X case A_WANTARRAY: X { X extern int wantarray; X X if (wantarray == G_ARRAY) X st[++sp] = &str_yes; X else X st[++sp] = &str_no; X } X#ifdef DEBUGGING X tmps = "WANTARRAY"; X#endif X break; X case A_INDREAD: X last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE); X old_record_separator = record_separator; X goto do_read; X case A_GLOB: X argflags |= AF_POST; /* enable newline chopping */ X last_in_stab = argptr.arg_stab; X old_record_separator = record_separator; X if (csh > 0) X record_separator = 0; X else X record_separator = '\n'; X goto do_read; X case A_READ: X last_in_stab = argptr.arg_stab; X old_record_separator = record_separator; X do_read: X if (anum > 1) /* assign to scalar */ X gimme = G_SCALAR; /* force context to scalar */ X ++sp; X fp = Nullfp; X if (stab_io(last_in_stab)) { X fp = stab_io(last_in_stab)->ifp; X if (!fp) { X if (stab_io(last_in_stab)->flags & IOF_ARGV) { X if (stab_io(last_in_stab)->flags & IOF_START) { X stab_io(last_in_stab)->flags &= ~IOF_START; X stab_io(last_in_stab)->lines = 0; X if (alen(stab_array(last_in_stab)) < 0) { X tmpstr = str_make("-",1); /* assume stdin */ X (void)apush(stab_array(last_in_stab), tmpstr); X } X } X fp = nextargv(last_in_stab); X if (!fp) /* Note: fp != stab_io(last_in_stab)->ifp */ X (void)do_close(last_in_stab,FALSE); /* now it does*/ X } X else if (argtype == A_GLOB) { X (void) interp(str,stab_val(last_in_stab),sp); X st = stack->ary_array; X tmpstr = Str_new(55,0); X if (csh > 0) { X str_set(tmpstr,"/bin/csh -cf 'set nonomatch; glob "); X str_scat(tmpstr,str); X str_cat(tmpstr,"'|"); X } X else { X str_set(tmpstr, "echo "); X str_scat(tmpstr,str); X str_cat(tmpstr, X "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); X } X (void)do_open(last_in_stab,tmpstr->str_ptr); X fp = stab_io(last_in_stab)->ifp; X } X } X } X if (!fp && dowarn) X warn("Read on closed filehandle <%s>",stab_name(last_in_stab)); X keepgoing: X if (!fp) X st[sp] = &str_undef; X else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) { X clearerr(fp); X if (stab_io(last_in_stab)->flags & IOF_ARGV) { X fp = nextargv(last_in_stab); X if (fp) X goto keepgoing; X (void)do_close(last_in_stab,FALSE); X stab_io(last_in_stab)->flags |= IOF_START; X } X else if (argflags & AF_POST) { X (void)do_close(last_in_stab,FALSE); X } X st[sp] = &str_undef; X record_separator = old_record_separator; X if (gimme == G_ARRAY) { X --sp; X goto array_return; X } X break; X } X else { X stab_io(last_in_stab)->lines++; X st[sp] = str; X#ifdef TAINT X str->str_tainted = 1; /* Anything from the outside world...*/ X#endif X if (argflags & AF_POST) { X if (str->str_cur > 0) X str->str_cur--; X if (str->str_ptr[str->str_cur] == record_separator) X str->str_ptr[str->str_cur] = '\0'; X else X str->str_cur++; X for (tmps = str->str_ptr; *tmps; tmps++) X if (!isalpha(*tmps) && !isdigit(*tmps) && X index("$&*(){}[]'\";\\|?<>~`",*tmps)) X break; X if (*tmps && stat(str->str_ptr,&statbuf) < 0) X goto keepgoing; /* unmatched wildcard? */ X } X if (gimme == G_ARRAY) { X st[sp] = str_static(st[sp]); X if (++sp > stack->ary_max) { X astore(stack, sp, Nullstr); X st = stack->ary_array; X } X goto keepgoing; X } X } X record_separator = old_record_separator; X#ifdef DEBUGGING X tmps = "READ"; X#endif X break; X } X#ifdef DEBUGGING X if (debug & 8) X deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp])); X#endif X if (anum < 8) X arglast[anum] = sp; X } !STUFFY!FUNK! echo "" echo "End of kit 19 (of 24)" cat /dev/null >kit19isdone 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; 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." chmod 755 Configure ;; *) echo "You have run$run." echo "You still need to run$todo." ;; esac : Someone might mail this, so... exit -- Please send comp.sources.unix-related mail to rsalz@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.