Usenet 1994 October

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

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

Wrap

Internet Message Format | 1989-11-01 | 49.1 KB

Subject: v20i100: Perl, a language with features of C/sed/awk/shell/etc, Part17/24 Newsgroups: comp.sources.unix Sender: sources Approved: rsalz@uunet.UU.NET Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> Posting-number: Volume 20, Issue 100 Archive-name: perl3.0/part17 #! /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 17 (of 24). If kit 17 is complete, the line" echo '"'"End of kit 17 (of 24)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir eg 2>/dev/null echo Extracting util.c sed >util.c <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: util.c,v 3.0 89/10/18 15:32:43 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: util.c,v $ X * Revision 3.0 89/10/18 15:32:43 lwall X * 3.0 baseline X * X */ X X#include "EXTERN.h" X#include "perl.h" X#include "errno.h" X#include <signal.h> X X#ifdef I_VFORK X# include <vfork.h> X#endif X X#ifdef I_VARARGS X# include <varargs.h> X#endif X X#define FLUSH X Xstatic char nomem[] = "Out of memory!\n"; X X/* paranoid version of malloc */ X X#ifdef DEBUGGING Xstatic int an = 0; X#endif X X/* NOTE: Do not call the next three routines directly. Use the macros X * in handy.h, so that we can easily redefine everything to do tracking of X * allocated hunks back to the original New to track down any memory leaks. X */ X Xchar * Xsafemalloc(size) XMEM_SIZE size; X{ X char *ptr; X char *malloc(); X X ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ X#ifdef DEBUGGING X# ifndef I286 X if (debug & 128) X fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); X# else X if (debug & 128) X fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",ptr,an++,size); X# endif X#endif X if (ptr != Nullch) X return ptr; X else { X fputs(nomem,stdout) FLUSH; X exit(1); X } X /*NOTREACHED*/ X#ifdef lint X return ptr; X#endif X} X X/* paranoid version of realloc */ X Xchar * Xsaferealloc(where,size) Xchar *where; XMEM_SIZE size; X{ X char *ptr; X char *realloc(); X X if (!where) X fatal("Null realloc"); X ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ X#ifdef DEBUGGING X# ifndef I286 X if (debug & 128) { X fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); X fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); X } X# else X if (debug & 128) { X fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++); X fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",ptr,an++,size); X } X# endif X#endif X if (ptr != Nullch) X return ptr; X else { X fputs(nomem,stdout) FLUSH; X exit(1); X } X /*NOTREACHED*/ X#ifdef lint X return ptr; X#endif X} X X/* safe version of free */ X Xvoid Xsafefree(where) Xchar *where; X{ X#ifdef DEBUGGING X# ifndef I286 X if (debug & 128) X fprintf(stderr,"0x%x: (%05d) free\n",where,an++); X# else X if (debug & 128) X fprintf(stderr,"0x%lx: (%05d) free\n",where,an++); X# endif X#endif X if (where) { X free(where); X } X} X X#ifdef LEAKTEST X X#define ALIGN sizeof(long) X Xchar * Xsafexmalloc(x,size) Xint x; XMEM_SIZE size; X{ X register char *where; X X where = safemalloc(size + ALIGN); X xcount[x]++; X where[0] = x % 100; X where[1] = x / 100; X return where + ALIGN; X} X Xchar * Xsafexrealloc(where,size) Xchar *where; XMEM_SIZE size; X{ X return saferealloc(where - ALIGN, size + ALIGN) + ALIGN; X} X Xvoid Xsafexfree(where) Xchar *where; X{ X int x; X X if (!where) X return; X where -= ALIGN; X x = where[0] + 100 * where[1]; X xcount[x]--; X safefree(where); X} X Xxstat() X{ X register int i; X X for (i = 0; i < MAXXCOUNT; i++) { X if (xcount[i] != lastxcount[i]) { X fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); X lastxcount[i] = xcount[i]; X } X } X} X X#endif /* LEAKTEST */ X X/* copy a string up to some (non-backslashed) delimiter, if any */ X Xchar * Xcpytill(to,from,fromend,delim,retlen) Xregister char *to, *from; Xregister char *fromend; Xregister int delim; Xint *retlen; X{ X char *origto = to; X X for (; from < fromend; from++,to++) { X if (*from == '\\') { X if (from[1] == delim) X from++; X else if (from[1] == '\\') X *to++ = *from++; X } X else if (*from == delim) X break; X *to = *from; X } X *to = '\0'; X *retlen = to - origto; X return from; X} X X/* return ptr to little string in big string, NULL if not found */ X/* This routine was donated by Corey Satten. */ X Xchar * Xinstr(big, little) Xregister char *big; Xregister char *little; X{ X register char *s, *x; X register int first; X X if (!little) X return big; X first = *little++; X if (!first) X return big; X while (*big) { X if (*big++ != first) X continue; X for (x=big,s=little; *s; /**/ ) { X if (!*x) X return Nullch; X if (*s++ != *x++) { X s--; X break; X } X } X if (!*s) X return big-1; X } X return Nullch; X} X X/* same as instr but allow embedded nulls */ X Xchar * Xninstr(big, bigend, little, lend) Xregister char *big; Xregister char *bigend; Xchar *little; Xchar *lend; X{ X register char *s, *x; X register int first = *little; X register char *littleend = lend; X X if (!first && little > littleend) X return big; X bigend -= littleend - little++; X while (big <= bigend) { X if (*big++ != first) X continue; X for (x=big,s=little; s < littleend; /**/ ) { X if (*s++ != *x++) { X s--; X break; X } X } X if (s >= littleend) X return big-1; X } X return Nullch; X} X X/* reverse of the above--find last substring */ X Xchar * Xrninstr(big, bigend, little, lend) Xregister char *big; Xchar *bigend; Xchar *little; Xchar *lend; X{ X register char *bigbeg; X register char *s, *x; X register int first = *little; X register char *littleend = lend; X X if (!first && little > littleend) X return bigend; X bigbeg = big; X big = bigend - (littleend - little++); X while (big >= bigbeg) { X if (*big-- != first) X continue; X for (x=big+2,s=little; s < littleend; /**/ ) { X if (*s++ != *x++) { X s--; X break; X } X } X if (s >= littleend) X return big+1; X } X return Nullch; X} X Xunsigned char fold[] = { X 0, 1, 2, 3, 4, 5, 6, 7, X 8, 9, 10, 11, 12, 13, 14, 15, X 16, 17, 18, 19, 20, 21, 22, 23, X 24, 25, 26, 27, 28, 29, 30, 31, X 32, 33, 34, 35, 36, 37, 38, 39, X 40, 41, 42, 43, 44, 45, 46, 47, X 48, 49, 50, 51, 52, 53, 54, 55, X 56, 57, 58, 59, 60, 61, 62, 63, X 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', X 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', X 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', X 'x', 'y', 'z', 91, 92, 93, 94, 95, X 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', X 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', X 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', X 'X', 'Y', 'Z', 123, 124, 125, 126, 127, X 128, 129, 130, 131, 132, 133, 134, 135, X 136, 137, 138, 139, 140, 141, 142, 143, X 144, 145, 146, 147, 148, 149, 150, 151, X 152, 153, 154, 155, 156, 157, 158, 159, X 160, 161, 162, 163, 164, 165, 166, 167, X 168, 169, 170, 171, 172, 173, 174, 175, X 176, 177, 178, 179, 180, 181, 182, 183, X 184, 185, 186, 187, 188, 189, 190, 191, X 192, 193, 194, 195, 196, 197, 198, 199, X 200, 201, 202, 203, 204, 205, 206, 207, X 208, 209, 210, 211, 212, 213, 214, 215, X 216, 217, 218, 219, 220, 221, 222, 223, X 224, 225, 226, 227, 228, 229, 230, 231, X 232, 233, 234, 235, 236, 237, 238, 239, X 240, 241, 242, 243, 244, 245, 246, 247, X 248, 249, 250, 251, 252, 253, 254, 255 X}; X Xstatic unsigned char freq[] = { X 1, 2, 84, 151, 154, 155, 156, 157, X 165, 246, 250, 3, 158, 7, 18, 29, X 40, 51, 62, 73, 85, 96, 107, 118, X 129, 140, 147, 148, 149, 150, 152, 153, X 255, 182, 224, 205, 174, 176, 180, 217, X 233, 232, 236, 187, 235, 228, 234, 226, X 222, 219, 211, 195, 188, 193, 185, 184, X 191, 183, 201, 229, 181, 220, 194, 162, X 163, 208, 186, 202, 200, 218, 198, 179, X 178, 214, 166, 170, 207, 199, 209, 206, X 204, 160, 212, 216, 215, 192, 175, 173, X 243, 172, 161, 190, 203, 189, 164, 230, X 167, 248, 227, 244, 242, 255, 241, 231, X 240, 253, 169, 210, 245, 237, 249, 247, X 239, 168, 252, 251, 254, 238, 223, 221, X 213, 225, 177, 197, 171, 196, 159, 4, X 5, 6, 8, 9, 10, 11, 12, 13, X 14, 15, 16, 17, 19, 20, 21, 22, X 23, 24, 25, 26, 27, 28, 30, 31, X 32, 33, 34, 35, 36, 37, 38, 39, X 41, 42, 43, 44, 45, 46, 47, 48, X 49, 50, 52, 53, 54, 55, 56, 57, X 58, 59, 60, 61, 63, 64, 65, 66, X 67, 68, 69, 70, 71, 72, 74, 75, X 76, 77, 78, 79, 80, 81, 82, 83, X 86, 87, 88, 89, 90, 91, 92, 93, X 94, 95, 97, 98, 99, 100, 101, 102, X 103, 104, 105, 106, 108, 109, 110, 111, X 112, 113, 114, 115, 116, 117, 119, 120, X 121, 122, 123, 124, 125, 126, 127, 128, X 130, 131, 132, 133, 134, 135, 136, 137, X 138, 139, 141, 142, 143, 144, 145, 146 X}; X Xvoid Xfbmcompile(str, iflag) XSTR *str; Xint iflag; X{ X register unsigned char *s; X register unsigned char *table; X register int i; X register int len = str->str_cur; X int rarest = 0; X int frequency = 256; X X str_grow(str,len+258); X#ifndef lint X table = (unsigned char*)(str->str_ptr + len + 1); X#else X table = Null(unsigned char*); X#endif X s = table - 2; X for (i = 0; i < 256; i++) { X table[i] = len; X } X i = 0; X#ifndef lint X while (s >= (unsigned char*)(str->str_ptr)) X#endif X { X if (table[*s] == len) { X#ifndef pdp11 X if (iflag) X table[*s] = table[fold[*s]] = i; X#else X if (iflag) { X int j; X j = fold[*s]; X table[j] = i; X table[*s] = i; X } X#endif /* pdp11 */ X else X table[*s] = i; X } X s--,i++; X } X str->str_pok |= SP_FBM; /* deep magic */ X X#ifndef lint X s = (unsigned char*)(str->str_ptr); /* deeper magic */ X#else X s = Null(unsigned char*); X#endif X if (iflag) { X register int tmp, foldtmp; X str->str_pok |= SP_CASEFOLD; X for (i = 0; i < len; i++) { X tmp=freq[s[i]]; X foldtmp=freq[fold[s[i]]]; X if (tmp < frequency && foldtmp < frequency) { X rarest = i; X /* choose most frequent among the two */ X frequency = (tmp > foldtmp) ? tmp : foldtmp; X } X } X } X else { X for (i = 0; i < len; i++) { X if (freq[s[i]] < frequency) { X rarest = i; X frequency = freq[s[i]]; X } X } X } X str->str_rare = s[rarest]; X str->str_state = rarest; X#ifdef DEBUGGING X if (debug & 512) X fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_state); X#endif X} X Xchar * Xfbminstr(big, bigend, littlestr) Xunsigned char *big; Xregister unsigned char *bigend; XSTR *littlestr; X{ X register unsigned char *s; X register int tmp; X register int littlelen; X register unsigned char *little; X register unsigned char *table; X register unsigned char *olds; X register unsigned char *oldlittle; X X#ifndef lint X if (!(littlestr->str_pok & SP_FBM)) X return instr((char*)big,littlestr->str_ptr); X#endif X X littlelen = littlestr->str_cur; X#ifndef lint X if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */ X little = (unsigned char*)littlestr->str_ptr; X if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */ X big = bigend - littlelen; /* just start near end */ X if (bigend[-1] == '\n' && little[littlelen-1] != '\n') X big--; X } X else { X s = bigend - littlelen; X if (*s == *little && bcmp(s,little,littlelen)==0) X return (char*)s; /* how sweet it is */ X else if (bigend[-1] == '\n' && little[littlelen-1] != '\n') { X s--; X if (*s == *little && bcmp(s,little,littlelen)==0) X return (char*)s; X } X return Nullch; X } X } X table = (unsigned char*)(littlestr->str_ptr + littlelen + 1); X#else X table = Null(unsigned char*); X#endif X s = big + --littlelen; X oldlittle = little = table - 2; X if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */ X while (s < bigend) { X top1: X if (tmp = table[*s]) { X s += tmp; X } X else { X tmp = littlelen; /* less expensive than calling strncmp() */ X olds = s; X while (tmp--) { X if (*--s == *--little || fold[*s] == *little) X continue; X s = olds + 1; /* here we pay the price for failure */ X little = oldlittle; X if (s < bigend) /* fake up continue to outer loop */ X goto top1; X return Nullch; X } X#ifndef lint X return (char *)s; X#endif X } X } X } X else { X while (s < bigend) { X top2: X if (tmp = table[*s]) { X s += tmp; X } X else { X tmp = littlelen; /* less expensive than calling strncmp() */ X olds = s; X while (tmp--) { X if (*--s == *--little) X continue; X s = olds + 1; /* here we pay the price for failure */ X little = oldlittle; X if (s < bigend) /* fake up continue to outer loop */ X goto top2; X return Nullch; X } X#ifndef lint X return (char *)s; X#endif X } X } X } X return Nullch; X} X Xchar * Xscreaminstr(bigstr, littlestr) XSTR *bigstr; XSTR *littlestr; X{ X register unsigned char *s, *x; X register unsigned char *big; X register int pos; X register int previous; X register int first; X register unsigned char *little; X register unsigned char *bigend; X register unsigned char *littleend; X X if ((pos = screamfirst[littlestr->str_rare]) < 0) X return Nullch; X#ifndef lint X little = (unsigned char *)(littlestr->str_ptr); X#else X little = Null(unsigned char *); X#endif X littleend = little + littlestr->str_cur; X first = *little++; X previous = littlestr->str_state; X#ifndef lint X big = (unsigned char *)(bigstr->str_ptr); X#else X big = Null(unsigned char*); X#endif X bigend = big + bigstr->str_cur; X big -= previous; X while (pos < previous) { X#ifndef lint X if (!(pos += screamnext[pos])) X#endif X return Nullch; X } X if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ X do { X if (big[pos] != first && big[pos] != fold[first]) X continue; X for (x=big+pos+1,s=little; s < littleend; /**/ ) { X if (x >= bigend) X return Nullch; X if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { X s--; X break; X } X } X if (s == littleend) X#ifndef lint X return (char *)(big+pos); X#else X return Nullch; X#endif X } while ( X#ifndef lint X pos += screamnext[pos] /* does this goof up anywhere? */ X#else X pos += screamnext[0] X#endif X ); X } X else { X do { X if (big[pos] != first) X continue; X for (x=big+pos+1,s=little; s < littleend; /**/ ) { X if (x >= bigend) X return Nullch; X if (*s++ != *x++) { X s--; X break; X } X } X if (s == littleend) X#ifndef lint X return (char *)(big+pos); X#else X return Nullch; X#endif X } while ( X#ifndef lint X pos += screamnext[pos] X#else X pos += screamnext[0] X#endif X ); X } X return Nullch; X} X X/* copy a string to a safe spot */ X Xchar * Xsavestr(str) Xchar *str; X{ X register char *newaddr; X X New(902,newaddr,strlen(str)+1,char); X (void)strcpy(newaddr,str); X return newaddr; X} X X/* same thing but with a known length */ X Xchar * Xnsavestr(str, len) Xchar *str; Xregister int len; X{ X register char *newaddr; X X New(903,newaddr,len+1,char); X (void)bcopy(str,newaddr,len); /* might not be null terminated */ X newaddr[len] = '\0'; /* is now */ X return newaddr; X} X X/* grow a static string to at least a certain length */ X Xvoid Xgrowstr(strptr,curlen,newlen) Xchar **strptr; Xint *curlen; Xint newlen; X{ X if (newlen > *curlen) { /* need more room? */ X if (*curlen) X Renew(*strptr,newlen,char); X else X New(905,*strptr,newlen,char); X *curlen = newlen; X } X} X Xextern int errno; X X#ifndef VARARGS X/*VARARGS1*/ Xmess(pat,a1,a2,a3,a4) Xchar *pat; Xlong a1, a2, a3, a4; X{ X char *s; X X s = buf; X (void)sprintf(s,pat,a1,a2,a3,a4); X s += strlen(s); X if (s[-1] != '\n') { X if (line) { X (void)sprintf(s," at %s line %ld", X in_eval?filename:origfilename, (long)line); X s += strlen(s); X } X if (last_in_stab && X stab_io(last_in_stab) && X stab_io(last_in_stab)->lines ) { X (void)sprintf(s,", <%s> line %ld", X last_in_stab == argvstab ? "" : stab_name(last_in_stab), X (long)stab_io(last_in_stab)->lines); X s += strlen(s); X } X (void)strcpy(s,".\n"); X } X} X X/*VARARGS1*/ Xfatal(pat,a1,a2,a3,a4) Xchar *pat; Xlong a1, a2, a3, a4; X{ X extern FILE *e_fp; X extern char *e_tmpname; X X mess(pat,a1,a2,a3,a4); X if (in_eval) { X str_set(stab_val(stabent("@",TRUE)),buf); X longjmp(eval_env,1); X } X fputs(buf,stderr); X (void)fflush(stderr); X if (e_fp) X (void)UNLINK(e_tmpname); X statusvalue >>= 8; X exit(errno?errno:(statusvalue?statusvalue:255)); X} X X/*VARARGS1*/ Xwarn(pat,a1,a2,a3,a4) Xchar *pat; Xlong a1, a2, a3, a4; X{ X mess(pat,a1,a2,a3,a4); X fputs(buf,stderr); X#ifdef LEAKTEST X#ifdef DEBUGGING X if (debug & 4096) X xstat(); X#endif X#endif X (void)fflush(stderr); X} X#else X/*VARARGS0*/ Xmess(args) Xva_list args; X{ X char *pat; X char *s; X#ifdef CHARVSPRINTF X char *vsprintf(); X#else X int vsprintf(); X#endif X X s = buf; X#ifdef lint X pat = Nullch; X#else X pat = va_arg(args, char *); X#endif X (void) vsprintf(s,pat,args); X X s += strlen(s); X if (s[-1] != '\n') { X if (line) { X (void)sprintf(s," at %s line %ld", X in_eval?filename:origfilename, (long)line); X s += strlen(s); X } X if (last_in_stab && X stab_io(last_in_stab) && X stab_io(last_in_stab)->lines ) { X (void)sprintf(s,", <%s> line %ld", X last_in_stab == argvstab ? "" : last_in_stab->str_magic->str_ptr, X (long)stab_io(last_in_stab)->lines); X s += strlen(s); X } X (void)strcpy(s,".\n"); X } X} X X/*VARARGS0*/ Xfatal(va_alist) Xva_dcl X{ X va_list args; X extern FILE *e_fp; X extern char *e_tmpname; X X#ifndef lint X va_start(args); X#else X args = 0; X#endif X mess(args); X va_end(args); X if (in_eval) { X str_set(stab_val(stabent("@",TRUE)),buf); X longjmp(eval_env,1); X } X fputs(buf,stderr); X (void)fflush(stderr); X if (e_fp) X (void)UNLINK(e_tmpname); X statusvalue >>= 8; X exit((int)(errno?errno:(statusvalue?statusvalue:255))); X} X X/*VARARGS0*/ Xwarn(va_alist) Xva_dcl X{ X va_list args; X X#ifndef lint X va_start(args); X#else X args = 0; X#endif X mess(args); X va_end(args); X X fputs(buf,stderr); X#ifdef LEAKTEST X#ifdef DEBUGGING X if (debug & 4096) X xstat(); X#endif X#endif X (void)fflush(stderr); X} X#endif X Xstatic bool firstsetenv = TRUE; Xextern char **environ; X Xvoid Xsetenv(nam,val) Xchar *nam, *val; X{ X register int i=envix(nam); /* where does it go? */ X X if (!val) { X while (environ[i]) { X environ[i] = environ[i+1]; X i++; X } X return; X } X if (!environ[i]) { /* does not exist yet */ X if (firstsetenv) { /* need we copy environment? */ X int j; X char **tmpenv; X X New(901,tmpenv, i+2, char*); X firstsetenv = FALSE; X for (j=0; j<i; j++) /* copy environment */ X tmpenv[j] = environ[j]; X environ = tmpenv; /* tell exec where it is now */ X } X else X Renew(environ, i+2, char*); /* just expand it a bit */ X environ[i+1] = Nullch; /* make sure it's null terminated */ X } X New(904, environ[i], strlen(nam) + strlen(val) + 2, char); X /* this may or may not be in */ X /* the old environ structure */ X (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ X} X Xint Xenvix(nam) Xchar *nam; X{ X register int i, len = strlen(nam); X X for (i = 0; environ[i]; i++) { X if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') X break; /* strnEQ must come first to avoid */ X } /* potential SEGV's */ X return i; X} X X#ifdef EUNICE Xunlnk(f) /* unlink all versions of a file */ Xchar *f; X{ X int i; X X for (i = 0; unlink(f) >= 0; i++) ; X return i ? 0 : -1; X} X#endif X X#ifndef BCOPY X#ifndef MEMCPY Xchar * Xbcopy(from,to,len) Xregister char *from; Xregister char *to; Xregister int len; X{ X char *retval = to; X X while (len--) X *to++ = *from++; X return retval; X} X Xchar * Xbzero(loc,len) Xregister char *loc; Xregister int len; X{ X char *retval = loc; X X while (len--) X *loc++ = 0; X return retval; X} X#endif X#endif X X#ifdef VARARGS X#ifndef VPRINTF X X#ifdef CHARVSPRINTF Xchar * X#else Xint X#endif Xvsprintf(dest, pat, args) Xchar *dest, *pat, *args; X{ X FILE fakebuf; X X fakebuf._ptr = dest; X fakebuf._cnt = 32767; X fakebuf._flag = _IOWRT|_IOSTRG; X _doprnt(pat, args, &fakebuf); /* what a kludge */ X (void)putc('\0', &fakebuf); X#ifdef CHARVSPRINTF X return(dest); X#else X return 0; /* perl doesn't use return value */ X#endif X} X X#ifdef DEBUGGING Xint Xvfprintf(fd, pat, args) XFILE *fd; Xchar *pat, *args; X{ X _doprnt(pat, args, fd); X return 0; /* wrong, but perl doesn't use the return value */ X} X#endif X#endif /* VPRINTF */ X#endif /* VARARGS */ X X#ifdef MYSWAP X#if BYTEORDER != 04321 Xshort Xmy_swap(s) Xshort s; X{ X#if (BYTEORDER & 1) == 0 X short result; X X result = ((s & 255) << 8) + ((s >> 8) & 255); X return result; X#else X return s; X#endif X} X Xlong Xhtonl(l) Xregister long l; X{ X union { X long result; X char c[4]; X } u; X X#if BYTEORDER == 01234 X u.c[0] = (l >> 24) & 255; X u.c[1] = (l >> 16) & 255; X u.c[2] = (l >> 8) & 255; X u.c[3] = l & 255; X return u.result; X#else X#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7) X fatal("Unknown BYTEORDER\n"); X#else X register int o; X register int s; X X for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) { X u.c[o & 7] = (l >> s) & 255; X } X return u.result; X#endif X#endif X} X Xlong Xntohl(l) Xregister long l; X{ X union { X long l; X char c[4]; X } u; X X#if BYTEORDER == 01234 X u.c[0] = (l >> 24) & 255; X u.c[1] = (l >> 16) & 255; X u.c[2] = (l >> 8) & 255; X u.c[3] = l & 255; X return u.l; X#else X#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7) X fatal("Unknown BYTEORDER\n"); X#else X register int o; X register int s; X X u.l = l; X l = 0; X for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) { X l |= (u.c[o & 7] & 255) << s; X } X return l; X#endif X#endif X} X X#endif /* BYTEORDER != 04321 */ X#endif /* HTONS */ X XFILE * Xmypopen(cmd,mode) Xchar *cmd; Xchar *mode; X{ X int p[2]; X register int this, that; X register int pid; X STR *str; X int doexec = strNE(cmd,"-"); X X if (pipe(p) < 0) X return Nullfp; X this = (*mode == 'w'); X that = !this; X while ((pid = (doexec?vfork():fork())) < 0) { X if (errno != EAGAIN) { X close(p[this]); X if (!doexec) X fatal("Can't fork"); X return Nullfp; X } X sleep(5); X } X if (pid == 0) { X#define THIS that X#define THAT this X close(p[THAT]); X if (p[THIS] != (*mode == 'r')) { X dup2(p[THIS], *mode == 'r'); X close(p[THIS]); X } X if (doexec) { X do_exec(cmd); /* may or may not use the shell */ X _exit(1); X } X if (tmpstab = stabent("$",allstabs)) X str_numset(STAB_STR(tmpstab),(double)getpid()); X return Nullfp; X#undef THIS X#undef THAT X } X close(p[that]); X str = afetch(pidstatary,p[this],TRUE); X str_numset(str,(double)pid); X str->str_cur = 0; X forkprocess = pid; X return fdopen(p[this], mode); X} X X#ifndef DUP2 Xdup2(oldfd,newfd) Xint oldfd; Xint newfd; X{ X close(newfd); X while (dup(oldfd) != newfd) ; /* good enough for our purposes */ X} X#endif X Xint Xmypclose(ptr) XFILE *ptr; X{ X register int result; X#ifdef VOIDSIG X void (*hstat)(), (*istat)(), (*qstat)(); X#else X int (*hstat)(), (*istat)(), (*qstat)(); X#endif X int status; X STR *str; X register int pid; X X str = afetch(pidstatary,fileno(ptr),TRUE); X fclose(ptr); X pid = (int)str_gnum(str); X if (!pid) X return -1; X hstat = signal(SIGHUP, SIG_IGN); X istat = signal(SIGINT, SIG_IGN); X qstat = signal(SIGQUIT, SIG_IGN); X#ifdef WAIT4 X if (wait4(pid,&status,0,Null(struct rusage *)) < 0) X status = -1; X#else X if (pid < 0) /* already exited? */ X status = str->str_cur; X else { X while ((result = wait(&status)) != pid && result >= 0) X pidgone(result,status); X if (result < 0) X status = -1; X } X#endif X signal(SIGHUP, hstat); X signal(SIGINT, istat); X signal(SIGQUIT, qstat); X str_numset(str,0.0); X return(status); X} X Xpidgone(pid,status) Xint pid; Xint status; X{ X#ifdef WAIT4 X return; X#else X register int count; X register STR *str; X X for (count = pidstatary->ary_fill; count >= 0; --count) { X if ((str = afetch(pidstatary,count,FALSE)) && X ((int)str->str_u.str_nval) == pid) { X str_numset(str, -str->str_u.str_nval); X str->str_cur = status; X return; X } X } X#endif X} X X#ifndef MEMCMP Xmemcmp(s1,s2,len) Xregister unsigned char *s1; Xregister unsigned char *s2; Xregister int len; X{ X register int tmp; X X while (len--) { X if (tmp = *s1++ - *s2++) X return tmp; X } X return 0; X} X#endif /* MEMCMP */ !STUFFY!FUNK! echo Extracting perly.c sed >perly.c <<'!STUFFY!FUNK!' -e 's/X//' Xchar rcsid[] = "$Header: perly.c,v 3.0 89/10/18 15:22:21 lwall Locked $\nPatch level: ###\n"; 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: perly.c,v $ X * Revision 3.0 89/10/18 15:22:21 lwall X * 3.0 baseline X * X */ X X#include "EXTERN.h" X#include "perl.h" X#include "perly.h" X#include "patchlevel.h" X X#ifdef IAMSUID X#ifndef DOSUID X#define DOSUID X#endif X#endif X X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW X#ifdef DOSUID X#undef DOSUID X#endif X#endif X Xmain(argc,argv,env) Xregister int argc; Xregister char **argv; Xregister char **env; X{ X register STR *str; X register char *s; X char *index(), *strcpy(), *getenv(); X bool dosearch = FALSE; X char **origargv = argv; X#ifdef DOSUID X char *validarg = ""; X#endif X X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW X#ifdef IAMSUID X#undef IAMSUID X fatal("suidperl is no longer needed since the kernel can now execute\n\ Xsetuid perl scripts securely.\n"); X#endif X#endif X X uid = (int)getuid(); X euid = (int)geteuid(); X gid = (int)getgid(); X egid = (int)getegid(); X if (do_undump) { X do_undump = 0; X loop_ptr = 0; /* start label stack again */ X goto just_doit; X } X (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); X linestr = Str_new(65,80); X str_nset(linestr,"",0); X str = str_make("",0); /* first used for -I flags */ X curstash = defstash = hnew(0); X curstname = str_make("main",4); X stab_xhash(stabent("_main",TRUE)) = defstash; X incstab = aadd(stabent("INC",TRUE)); X incstab->str_pok |= SP_MULTI; X for (argc--,argv++; argc; argc--,argv++) { X if (argv[0][0] != '-' || !argv[0][1]) X break; X#ifdef DOSUID X if (*validarg) X validarg = " PHOOEY "; X else X validarg = argv[0]; X#endif X s = argv[0]+1; X reswitch: X switch (*s) { X case 'a': X minus_a = TRUE; X s++; X goto reswitch; X case 'd': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -d allowed in setuid scripts"); X#endif X perldb = TRUE; X s++; X goto reswitch; X#ifdef DEBUGGING X case 'D': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -D allowed in setuid scripts"); X#endif X debug = atoi(s+1); X#ifdef YYDEBUG X yydebug = (debug & 1); X#endif X break; X#endif X case 'e': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -e allowed in setuid scripts"); X#endif X if (!e_fp) { X e_tmpname = savestr(TMPPATH); X (void)mktemp(e_tmpname); X e_fp = fopen(e_tmpname,"w"); X } X if (argv[1]) X fputs(argv[1],e_fp); X (void)putc('\n', e_fp); X argc--,argv++; X break; X case 'i': X inplace = savestr(s+1); X argvoutstab = stabent("ARGVOUT",TRUE); X break; X case 'I': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -I allowed in setuid scripts"); X#endif X str_cat(str,"-"); X str_cat(str,s); X str_cat(str," "); X if (*++s) { X (void)apush(stab_array(incstab),str_make(s,0)); X } X else { X (void)apush(stab_array(incstab),str_make(argv[1],0)); X str_cat(str,argv[1]); X argc--,argv++; X str_cat(str," "); X } X break; X case 'n': X minus_n = TRUE; X s++; X goto reswitch; X case 'p': X minus_p = TRUE; X s++; X goto reswitch; X case 'P': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -P allowed in setuid scripts"); X#endif X preprocess = TRUE; X s++; X goto reswitch; X case 's': X#ifdef TAINT X if (euid != uid || egid != gid) X fatal("No -s allowed in setuid scripts"); X#endif X doswitches = TRUE; X s++; X goto reswitch; X case 'S': X dosearch = TRUE; X s++; X goto reswitch; X case 'u': X do_undump = TRUE; X s++; X goto reswitch; X case 'U': X unsafe = TRUE; X s++; X goto reswitch; X case 'v': X fputs(rcsid,stdout); X fputs("\nCopyright (c) 1989, Larry Wall\n\n\ XPerl may be copied only under the terms of the GNU General Public License,\n\ Xa copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); X exit(0); X case 'w': X dowarn = TRUE; X s++; X goto reswitch; X case '-': X argc--,argv++; X goto switch_end; X case 0: X break; X default: X fatal("Unrecognized switch: -%s",s); X } X } X switch_end: X if (e_fp) { X (void)fclose(e_fp); X argc++,argv--; X argv[0] = e_tmpname; X } X#ifndef PRIVLIB X#define PRIVLIB "/usr/local/lib/perl" X#endif X (void)apush(stab_array(incstab),str_make(PRIVLIB,0)); X X str_set(&str_no,No); X str_set(&str_yes,Yes); X X /* open script */ X X if (argv[0] == Nullch) X argv[0] = "-"; X if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) { X char *xfound = Nullch, *xfailed = Nullch; X int len; X X bufend = s + strlen(s); X while (*s) { X s = cpytill(tokenbuf,s,bufend,':',&len); X if (*s) X s++; X if (len) X (void)strcat(tokenbuf+len,"/"); X (void)strcat(tokenbuf+len,argv[0]); X#ifdef DEBUGGING X if (debug & 1) X fprintf(stderr,"Looking for %s\n",tokenbuf); X#endif X if (stat(tokenbuf,&statbuf) < 0) /* not there? */ X continue; X if ((statbuf.st_mode & S_IFMT) == S_IFREG X && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) { X xfound = tokenbuf; /* bingo! */ X break; X } X if (!xfailed) X xfailed = savestr(tokenbuf); X } X if (!xfound) X fatal("Can't execute %s", xfailed ? xfailed : argv[0] ); X if (xfailed) X Safefree(xfailed); X argv[0] = savestr(xfound); X } X X pidstatary = anew(Nullstab); /* for remembering popen pids, status */ X X filename = savestr(argv[0]); X origfilename = savestr(filename); X if (strEQ(filename,"-")) X argv[0] = ""; X if (preprocess) { X str_cat(str,"-I"); X str_cat(str,PRIVLIB); X (void)sprintf(buf, "\ X/bin/sed -e '/^[^#]/b' \ X -e '/^#[ ]*include[ ]/b' \ X -e '/^#[ ]*define[ ]/b' \ X -e '/^#[ ]*if[ ]/b' \ X -e '/^#[ ]*ifdef[ ]/b' \ X -e '/^#[ ]*ifndef[ ]/b' \ X -e '/^#[ ]*else/b' \ X -e '/^#[ ]*endif/b' \ X -e 's/^#.*//' \ X %s | %s -C %s %s", X argv[0], CPPSTDIN, str_get(str), CPPMINUS); X#ifdef IAMSUID /* actually, this is caught earlier */ X if (euid != uid && !euid) /* if running suidperl */ X#ifdef SETEUID X (void)seteuid(uid); /* musn't stay setuid root */ X#else X#ifdef SETREUID X (void)setreuid(-1, uid); X#else X setuid(uid); X#endif X#endif X#endif /* IAMSUID */ X rsfp = mypopen(buf,"r"); X } X else if (!*argv[0]) X rsfp = stdin; X else X rsfp = fopen(argv[0],"r"); X if (rsfp == Nullfp) { X extern char *sys_errlist[]; X extern int errno; X X#ifdef DOSUID X#ifndef IAMSUID /* in case script is not readable before setuid */ X if (euid && stat(filename,&statbuf) >= 0 && X statbuf.st_mode & (S_ISUID|S_ISGID)) { X (void)sprintf(buf, "%s/%s", BIN, "suidperl"); X execv(buf, origargv); /* try again */ X fatal("Can't do setuid\n"); X } X#endif X#endif X fatal("Can't open perl script \"%s\": %s\n", X filename, sys_errlist[errno]); X } X str_free(str); /* free -I directories */ X X /* do we need to emulate setuid on scripts? */ X X /* This code is for those BSD systems that have setuid #! scripts disabled X * in the kernel because of a security problem. Merely defining DOSUID X * in perl will not fix that problem, but if you have disabled setuid X * scripts in the kernel, this will attempt to emulate setuid and setgid X * on scripts that have those now-otherwise-useless bits set. The setuid X * root version must be called suidperl. If regular perl discovers that X * it has opened a setuid script, it calls suidperl with the same argv X * that it had. If suidperl finds that the script it has just opened X * is NOT setuid root, it sets the effective uid back to the uid. We X * don't just make perl setuid root because that loses the effective X * uid we had before invoking perl, if it was different from the uid. X * X * DOSUID must be defined in both perl and suidperl, and IAMSUID must X * be defined in suidperl only. suidperl must be setuid root. The X * Configure script will set this up for you if you want it. X * X * There is also the possibility of have a script which is running X * set-id due to a C wrapper. We want to do the TAINT checks X * on these set-id scripts, but don't want to have the overhead of X * them in normal perl, and can't use suidperl because it will lose X * the effective uid info, so we have an additional non-setuid root X * version called taintperl that just does the TAINT checks. X */ X X#ifdef DOSUID X if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ X fatal("Can't stat script \"%s\"",filename); X if (statbuf.st_mode & (S_ISUID|S_ISGID)) { X int len; X X#ifdef IAMSUID X#ifndef SETREUID X /* On this access check to make sure the directories are readable, X * there is actually a small window that the user could use to make X * filename point to an accessible directory. So there is a faint X * chance that someone could execute a setuid script down in a X * non-accessible directory. I don't know what to do about that. X * But I don't think it's too important. The manual lies when X * it says access() is useful in setuid programs. X */ X if (access(filename,1)) /* as a double check */ X fatal("Permission denied"); X#else X /* If we can swap euid and uid, then we can determine access rights X * with a simple stat of the file, and then compare device and X * inode to make sure we did stat() on the same file we opened. X * Then we just have to make sure he or she can execute it. X */ X { X struct stat tmpstatbuf; X X if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid) X fatal("Can't swap uid and euid"); /* really paranoid */ X if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */ X fatal("Permission denied"); X if (tmpstatbuf.st_dev != statbuf.st_dev || X tmpstatbuf.st_ino != statbuf.st_ino) { X (void)fclose(rsfp); X if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ X fprintf(rsfp, X"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ X(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", X uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, X statbuf.st_dev, statbuf.st_ino, X filename, statbuf.st_uid, statbuf.st_gid); X (void)mypclose(rsfp); X } X fatal("Permission denied\n"); X } X if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) X fatal("Can't reswap uid and euid"); X if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */ X fatal("Permission denied\n"); X } X#endif /* SETREUID */ X#endif /* IAMSUID */ X X if ((statbuf.st_mode & S_IFMT) != S_IFREG) X fatal("Permission denied"); X if ((statbuf.st_mode >> 6) & S_IWRITE) X fatal("Setuid/gid script is writable by world"); X doswitches = FALSE; /* -s is insecure in suid */ X line++; X if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || X strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ X fatal("No #! line"); X for (s = tokenbuf+2; !isspace(*s); s++) ; X if (strnNE(s-4,"perl",4)) /* sanity check */ X fatal("Not a perl script"); X while (*s == ' ' || *s == '\t') s++; X /* X * #! arg must be what we saw above. They can invoke it by X * mentioning suidperl explicitly, but they may not add any strange X * arguments beyond what #! says if they do invoke suidperl that way. X */ X len = strlen(validarg); X if (strEQ(validarg," PHOOEY ") || X strnNE(s,validarg,len) || !isspace(s[len])) X fatal("Args must match #! line"); X X#ifndef IAMSUID X if (euid != uid && (statbuf.st_mode & S_ISUID) && X euid == statbuf.st_uid) X if (!do_undump) X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); X#endif /* IAMSUID */ X X if (euid) { /* oops, we're not the setuid root perl */ X (void)fclose(rsfp); X#ifndef IAMSUID X (void)sprintf(buf, "%s/%s", BIN, "suidperl"); X execv(buf, origargv); /* try again */ X#endif X fatal("Can't do setuid\n"); X } X X if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid()) X#ifdef SETEGID X (void)setegid(statbuf.st_gid); X#else X#ifdef SETREGID X (void)setregid((GIDTYPE)-1,statbuf.st_gid); X#else X setgid(statbuf.st_gid); X#endif X#endif X if (statbuf.st_mode & S_ISUID) { X if (statbuf.st_uid != euid) X#ifdef SETEUID X (void)seteuid(statbuf.st_uid); /* all that for this */ X#else X#ifdef SETREUID X (void)setreuid((UIDTYPE)-1,statbuf.st_uid); X#else X setuid(statbuf.st_uid); X#endif X#endif X } X else if (uid) /* oops, mustn't run as root */ X#ifdef SETEUID X (void)seteuid((UIDTYPE)uid); X#else X#ifdef SETREUID X (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid); X#else X setuid((UIDTYPE)uid); X#endif X#endif X euid = (int)geteuid(); X if (!cando(S_IEXEC,TRUE,&statbuf)) X fatal("Permission denied\n"); /* they can't do this */ X } X#ifdef IAMSUID X else if (preprocess) X fatal("-P not allowed for setuid/setgid script\n"); X else X fatal("Script is not setuid/setgid in suidperl\n"); X#else X#ifndef TAINT /* we aren't taintperl or suidperl */ X /* script has a wrapper--can't run suidperl or we lose euid */ X else if (euid != uid || egid != gid) { X (void)fclose(rsfp); X (void)sprintf(buf, "%s/%s", BIN, "taintperl"); X execv(buf, origargv); /* try again */ X fatal("Can't run setuid script with taint checks"); X } X#endif /* TAINT */ X#endif /* IAMSUID */ X#else /* !DOSUID */ X#ifndef TAINT /* we aren't taintperl or suidperl */ X if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ X#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW X fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ X if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) X || X (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) X ) X if (!do_undump) X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); X#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ X /* not set-id, must be wrapped */ X (void)fclose(rsfp); X (void)sprintf(buf, "%s/%s", BIN, "taintperl"); X execv(buf, origargv); /* try again */ X fatal("Can't run setuid script with taint checks"); X } X#endif /* TAINT */ X#endif /* DOSUID */ X X defstab = stabent("_",TRUE); X X if (perldb) { X debstash = hnew(0); X stab_xhash(stabent("_DB",TRUE)) = debstash; X curstash = debstash; X lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE)))); X tmpstab->str_pok |= SP_MULTI; X subname = str_make("main",4); X DBstab = stabent("DB",TRUE); X DBstab->str_pok |= SP_MULTI; X DBsub = hadd(tmpstab = stabent("sub",TRUE)); X tmpstab->str_pok |= SP_MULTI; X DBsingle = stab_val((tmpstab = stabent("single",TRUE))); X tmpstab->str_pok |= SP_MULTI; X curstash = defstash; X } X X /* init tokener */ X X bufend = bufptr = str_get(linestr); X X savestack = anew(Nullstab); /* for saving non-local values */ X stack = anew(Nullstab); /* for saving non-local values */ X stack->ary_flags = 0; /* not a real array */ X X /* now parse the script */ X X error_count = 0; X if (yyparse() || error_count) X fatal("Execution aborted due to compilation errors.\n"); X X New(50,loop_stack,128,struct loop); X New(51,debname,128,char); X New(52,debdelim,128,char); X curstash = defstash; X X preprocess = FALSE; X if (e_fp) { X e_fp = Nullfp; X (void)UNLINK(e_tmpname); X } X X /* initialize everything that won't change if we undump */ X X if (sigstab = stabent("SIG",allstabs)) { X sigstab->str_pok |= SP_MULTI; X (void)hadd(sigstab); X } X X magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':"); X X amperstab = stabent("&",allstabs); X leftstab = stabent("`",allstabs); X rightstab = stabent("'",allstabs); X sawampersand = (amperstab || leftstab || rightstab); X if (tmpstab = stabent(":",allstabs)) X str_set(STAB_STR(tmpstab),chopset); X X /* these aren't necessarily magical */ X if (tmpstab = stabent(";",allstabs)) X str_set(STAB_STR(tmpstab),"\034"); X#ifdef TAINT X tainted = 1; X#endif X if (tmpstab = stabent("0",allstabs)) X str_set(STAB_STR(tmpstab),origfilename); X#ifdef TAINT X tainted = 0; X#endif X if (tmpstab = stabent("]",allstabs)) X str_set(STAB_STR(tmpstab),rcsid); X str_nset(stab_val(stabent("\"", TRUE)), " ", 1); X X stdinstab = stabent("STDIN",TRUE); X stdinstab->str_pok |= SP_MULTI; X stab_io(stdinstab) = stio_new(); X stab_io(stdinstab)->ifp = stdin; X tmpstab = stabent("stdin",TRUE); X stab_io(tmpstab) = stab_io(stdinstab); X tmpstab->str_pok |= SP_MULTI; X X tmpstab = stabent("STDOUT",TRUE); X tmpstab->str_pok |= SP_MULTI; X stab_io(tmpstab) = stio_new(); X stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; X defoutstab = tmpstab; X tmpstab = stabent("stdout",TRUE); X stab_io(tmpstab) = stab_io(defoutstab); X tmpstab->str_pok |= SP_MULTI; X X curoutstab = stabent("STDERR",TRUE); X curoutstab->str_pok |= SP_MULTI; X stab_io(curoutstab) = stio_new(); X stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr; X tmpstab = stabent("stderr",TRUE); X stab_io(tmpstab) = stab_io(curoutstab); X tmpstab->str_pok |= SP_MULTI; X curoutstab = defoutstab; /* switch back to STDOUT */ X X statname = Str_new(66,0); /* last filename we did stat on */ X X perldb = FALSE; /* don't try to instrument evals */ X X if (dowarn) { X stab_check('A','Z'); X stab_check('a','z'); X } X X if (do_undump) X abort(); X X just_doit: /* come here if running an undumped a.out */ X argc--,argv++; /* skip name of script */ X if (doswitches) { X for (; argc > 0 && **argv == '-'; argc--,argv++) { X if (argv[0][1] == '-') { X argc--,argv++; X break; X } X str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); X } X } X#ifdef TAINT X tainted = 1; X#endif X if (argvstab = stabent("ARGV",allstabs)) { X argvstab->str_pok |= SP_MULTI; X (void)aadd(argvstab); X for (; argc > 0; argc--,argv++) { X (void)apush(stab_array(argvstab),str_make(argv[0],0)); X } X } X#ifdef TAINT X (void) stabent("ENV",TRUE); /* must test PATH and IFS */ X#endif X if (envstab = stabent("ENV",allstabs)) { X envstab->str_pok |= SP_MULTI; X (void)hadd(envstab); X for (; *env; env++) { X if (!(s = index(*env,'='))) X continue; X *s++ = '\0'; X str = str_make(s--,0); X str_magic(str, envstab, 'E', *env, s - *env); X (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); X *s = '='; X } X } X#ifdef TAINT X tainted = 0; X#endif X if (tmpstab = stabent("$",allstabs)) X str_numset(STAB_STR(tmpstab),(double)getpid()); X X if (setjmp(top_env)) /* sets goto_targ on longjump */ X loop_ptr = 0; /* start label stack again */ X X#ifdef DEBUGGING X if (debug & 1024) X dump_all(); X if (debug) X fprintf(stderr,"\nEXECUTING...\n\n"); X#endif X X /* do it */ X X (void) cmd_exec(main_root,G_SCALAR,-1); X X if (goto_targ) X fatal("Can't find label \"%s\"--aborting",goto_targ); X exit(0); X /* NOTREACHED */ X} X Xmagicalize(list) Xregister char *list; X{ X register STAB *stab; X char sym[2]; X X sym[1] = '\0'; X while (*sym = *list++) { X if (stab = stabent(sym,allstabs)) { X stab_flags(stab) = SF_VMAGIC; X str_magic(stab_val(stab), stab, 0, Nullch, 0); X } X } X} X X/* this routine is in perly.c by virtue of being sort of an alternate main() */ X Xint Xdo_eval(str,optype,stash,gimme,arglast) XSTR *str; Xint optype; XHASH *stash; Xint gimme; Xint *arglast; X{ X STR **st = stack->ary_array; X int retval; X CMD *myroot; X ARRAY *ar; X int i; X char *oldfile = filename; X line_t oldline = line; X int oldtmps_base = tmps_base; X int oldsave = savestack->ary_fill; X SPAT *oldspat = curspat; X static char *last_eval = Nullch; X static CMD *last_root = Nullcmd; X int sp = arglast[0]; X X tmps_base = tmps_max; X if (curstash != stash) { X (void)savehptr(&curstash); X curstash = stash; X } X str_set(stab_val(stabent("@",TRUE)),""); X if (optype != O_DOFILE) { /* normal eval */ X filename = "(eval)"; X line = 1; X str_sset(linestr,str); X str_cat(linestr,";"); /* be kind to them */ X } X else { X if (last_root) { X Safefree(last_eval); X cmd_free(last_root); X last_root = Nullcmd; X } X filename = savestr(str_get(str)); /* can't free this easily */ X str_set(linestr,""); X rsfp = fopen(filename,"r"); X ar = stab_array(incstab); X if (!rsfp && *filename != '/') { X for (i = 0; i <= ar->ary_fill; i++) { X (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename); X rsfp = fopen(buf,"r"); X if (rsfp) { X filename = savestr(buf); X break; X } X } X } X if (!rsfp) { X filename = oldfile; X tmps_base = oldtmps_base; X if (gimme != G_ARRAY) X st[++sp] = &str_undef; X return sp; X } X line = 0; X } X in_eval++; X oldoldbufptr = oldbufptr = bufptr = str_get(linestr); X bufend = bufptr + linestr->str_cur; X if (setjmp(eval_env)) { X retval = 1; X last_root = Nullcmd; X } X else { X error_count = 0; X if (rsfp) X retval = yyparse(); X else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){ X retval = 0; X eval_root = last_root; /* no point in reparsing */ X } X else if (in_eval == 1) { X if (last_root) { X Safefree(last_eval); X cmd_free(last_root); X } X last_eval = savestr(bufptr); X last_root = Nullcmd; X retval = yyparse(); X if (!retval) X last_root = eval_root; X } X else X retval = yyparse(); X } X myroot = eval_root; /* in case cmd_exec does another eval! */ X if (retval || error_count) { X str = &str_undef; X last_root = Nullcmd; /* can't free on error, for some reason */ X if (rsfp) { X fclose(rsfp); X rsfp = 0; X } X } X else { X sp = cmd_exec(eval_root,gimme,sp); X st = stack->ary_array; X for (i = arglast[0] + 1; i <= sp; i++) X st[i] = str_static(st[i]); X /* if we don't save result, free zaps it */ X if (in_eval != 1 && myroot != last_root) X cmd_free(myroot); X } X in_eval--; X filename = oldfile; X line = oldline; X tmps_base = oldtmps_base; X curspat = oldspat; X if (savestack->ary_fill > oldsave) /* let them use local() */ X restorelist(oldsave); X return sp; X} !STUFFY!FUNK! echo Extracting eg/findcp sed >eg/findcp <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: findcp,v 3.0 89/10/18 15:13:47 lwall Locked $ X X# This is a wrapper around the find command that pretends find has a switch X# of the form -cp host:destination. It presumes your find implements -ls. X# It uses tar to do the actual copy. If your tar knows about the I switch X# you may prefer to use findtar, since this one has to do the tar in batches. X Xsub copy { X `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; X} X X$sourcedir = $ARGV[0]; Xif ($sourcedir =~ /^\//) { X $ARGV[0] = '.'; X unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } X} X X$args = join(' ',@ARGV); Xif ($args =~ s/-cp *([^ ]+)/-ls/) { X $dest = $1; X if ($dest =~ /(.*):(.*)/) { X $desthost = $1; X $destdir = $2; X } X else { X die "Malformed destination--should be host:directory"; X } X} Xelse { X die("No destination specified"); X} X Xopen(find,"find $args |") || die "Can't run find for you: $!"; X Xwhile (<find>) { X @x = split(' '); X if ($x[2] =~ /^d/) { next;} X chop($filename = $x[10]); X if (length($list) > 5000) { X do copy(); X $list = ''; X } X else { X $list .= ' '; X } X $list .= $filename; X} X Xif ($list) { X do copy(); X} !STUFFY!FUNK! echo "" echo "End of kit 17 (of 24)" cat /dev/null >kit17isdone 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