rsalz@bbn.com (Rich Salz) (07/13/88)
Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Posting-number: Volume 15, Issue 102
Archive-name: perl2/part13
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 15 through sh. When all 15 kits have been run, read README.
echo "This is perl 2.0 kit 13 (of 15). If kit 13 is complete, the line"
echo '"'"End of kit 13 (of 15)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg eg/scan t x2p 2>/dev/null
echo Extracting x2p/util.c
sed >x2p/util.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: util.c,v 2.0 88/06/05 00:16:07 root Exp $
X *
X * $Log: util.c,v $
X * Revision 2.0 88/06/05 00:16:07 root
X * Baseline version 2.0.
X *
X */
X
X#include <stdio.h>
X
X#include "handy.h"
X#include "EXTERN.h"
X#include "a2p.h"
X#include "INTERN.h"
X#include "util.h"
X
X#define FLUSH
X#define MEM_SIZE unsigned int
X
Xstatic char nomem[] = "Out of memory!\n";
X
X/* paranoid version of malloc */
X
Xstatic int an = 0;
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 if (debug & 128)
X fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
X#endif
X if (ptr != Nullch)
X return ptr;
X else {
X fputs(nomem,stdout) FLUSH;
X exit(1);
X }
X /*NOTREACHED*/
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 ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
X#ifdef DEBUGGING
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#endif
X if (ptr != Nullch)
X return ptr;
X else {
X fputs(nomem,stdout) FLUSH;
X exit(1);
X }
X /*NOTREACHED*/
X}
X
X/* safe version of free */
X
Xsafefree(where)
Xchar *where;
X{
X#ifdef DEBUGGING
X if (debug & 128)
X fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
X#endif
X free(where);
X}
X
X/* safe version of string copy */
X
Xchar *
Xsafecpy(to,from,len)
Xchar *to;
Xregister char *from;
Xregister int len;
X{
X register char *dest = to;
X
X if (from != Nullch)
X for (len--; len && (*dest++ = *from++); len--) ;
X *dest = '\0';
X return to;
X}
X
X#ifdef undef
X/* safe version of string concatenate, with \n deletion and space padding */
X
Xchar *
Xsafecat(to,from,len)
Xchar *to;
Xregister char *from;
Xregister int len;
X{
X register char *dest = to;
X
X len--; /* leave room for null */
X if (*dest) {
X while (len && *dest++) len--;
X if (len) {
X len--;
X *(dest-1) = ' ';
X }
X }
X if (from != Nullch)
X while (len && (*dest++ = *from++)) len--;
X if (len)
X dest--;
X if (*(dest-1) == '\n')
X dest--;
X *dest = '\0';
X return to;
X}
X#endif
X
X/* copy a string up to some (non-backslashed) delimiter, if any */
X
Xchar *
Xcpytill(to,from,delim)
Xregister char *to, *from;
Xregister int delim;
X{
X for (; *from; 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 return from;
X}
X
X
Xchar *
Xcpy2(to,from,delim)
Xregister char *to, *from;
Xregister int delim;
X{
X for (; *from; from++,to++) {
X if (*from == '\\')
X *to++ = *from++;
X else if (*from == '$')
X *to++ = '\\';
X else if (*from == delim)
X break;
X *to = *from;
X }
X *to = '\0';
X return from;
X}
X
X/* return ptr to little string in big string, NULL if not found */
X
Xchar *
Xinstr(big, little)
Xchar *big, *little;
X
X{
X register char *t, *s, *x;
X
X for (t = big; *t; t++) {
X for (x=t,s=little; *s; x++,s++) {
X if (!*x)
X return Nullch;
X if (*s != *x)
X break;
X }
X if (!*s)
X return t;
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 = safemalloc((MEM_SIZE)(strlen(str)+1));
X
X (void)strcpy(newaddr,str);
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 *strptr = saferealloc(*strptr,(MEM_SIZE)newlen);
X else
X *strptr = safemalloc((MEM_SIZE)newlen);
X *curlen = newlen;
X }
X}
X
X/*VARARGS1*/
Xfatal(pat,a1,a2,a3,a4)
Xchar *pat;
X{
X fprintf(stderr,pat,a1,a2,a3,a4);
X exit(1);
X}
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 (!environ[i]) { /* does not exist yet */
X if (firstsetenv) { /* need we copy environment? */
X int j;
X#ifndef lint
X char **tmpenv = (char**) /* point our wand at memory */
X safemalloc((i+2) * sizeof(char*));
X#else
X char **tmpenv = Null(char **);
X#endif /* lint */
X
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#ifndef lint
X else
X environ = (char**) saferealloc((char*) environ,
X (i+2) * sizeof(char*));
X /* just expand it a bit */
X#endif /* lint */
X environ[i+1] = Nullch; /* make sure it's null terminated */
X }
X environ[i] = safemalloc(strlen(nam) + strlen(val) + 2);
X /* this may or may not be in */
X /* the old environ structure */
X 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}
!STUFFY!FUNK!
echo Extracting eg/scan/scan_messages
sed >eg/scan/scan_messages <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_messages,v 2.0 88/06/05 00:17:46 root Exp $
X
X# This prints out extraordinary console messages. You'll need to customize.
X
Xchdir('/usr/adm/private/memories') || die "Can't cd.";
X
X$maxpos = `cat oldmsgs 2>&1`;
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
Xopen(Msgs, '/dev/null') || die "scan_messages: can't open messages";
X#else
Xopen(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages";
X#endif
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X $blksize,$blocks) = stat(Msgs);
X
Xif ($size < $maxpos) { # Did somebody truncate messages file?
X $maxpos = 0;
X}
X
Xseek(Msgs,$maxpos,0); # Start where we left off last time.
X
Xwhile (<Msgs>) {
X s/\[(\d+)\]/#/ && s/$1/#/g;
X#ifdef vax
X $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//;
X next if /root@.*:/;
X next if /^vmunix: 4.3 BSD UNIX/;
X next if /^vmunix: Copyright/;
X next if /^vmunix: avail mem =/;
X next if /^vmunix: SBIA0 at /;
X next if /^vmunix: disk ra81 is/;
X next if /^vmunix: dmf. at uba/;
X next if /^vmunix: dmf.:.*asynch/;
X next if /^vmunix: ex. at uba/;
X next if /^vmunix: ex.: HW/;
X next if /^vmunix: il. at uba/;
X next if /^vmunix: il.: hardware/;
X next if /^vmunix: ra. at uba/;
X next if /^vmunix: ra.: media/;
X next if /^vmunix: real mem/;
X next if /^vmunix: syncing disks/;
X next if /^vmunix: tms/;
X next if /^vmunix: tmscp. at uba/;
X next if /^vmunix: uba. at /;
X next if /^vmunix: uda. at /;
X next if /^vmunix: uda.: unit . ONLIN/;
X next if /^vmunix: .*buffers containing/;
X next if /^syslogd: .*newslog/;
X#endif
X next if /unknown service/;
X next if /^\.\.\.$/;
X if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) {
X $pfx = '';
X next;
X }
X next if /^[ \t]*$/;
X next if /^[ 0-9]*done$/;
X if (/^A/) {
X next if /^Accounting [sr]/;
X }
X elsif (/^C/) {
X next if /^Called from/;
X next if /^Copyright/;
X }
X elsif (/^E/) {
X next if /^End traceback/;
X next if /^Ethernet address =/;
X }
X elsif (/^K/) {
X next if /^KERNEL MODE/;
X }
X elsif (/^R/) {
X next if /^Rebooting Unix/;
X }
X elsif (/^S/) {
X next if /^Sun UNIX 4\.2 Release/;
X }
X elsif (/^W/) {
X next if /^WARNING: clock gained/;
X }
X elsif (/^a/) {
X next if /^arg /;
X next if /^avail mem =/;
X }
X elsif (/^b/) {
X next if /^bwtwo[0-9] at /;
X }
X elsif (/^c/) {
X next if /^cgone[0-9] at /;
X next if /^cdp[0-9] at /;
X next if /^csr /;
X }
X elsif (/^d/) {
X next if /^dcpa: init/;
X next if /^done$/;
X next if /^dts/;
X next if /^dump i\/o error/;
X next if /^dumping to dev/;
X next if /^dump succeeded/;
X $pfx = '*' if /^dev = /;
X }
X elsif (/^e/) {
X next if /^end \*\*/;
X next if /^error in copy/;
X }
X elsif (/^f/) {
X next if /^found /;
X }
X elsif (/^i/) {
X next if /^ib[0-9] at /;
X next if /^ie[0-9] at /;
X }
X elsif (/^l/) {
X next if /^le[0-9] at /;
X }
X elsif (/^m/) {
X next if /^mem = /;
X next if /^mt[0-9] at /;
X next if /^mti[0-9] at /;
X $pfx = '*' if /^mode = /;
X }
X elsif (/^n/) {
X next if /^not found /;
X }
X elsif (/^p/) {
X next if /^page map /;
X next if /^pi[0-9] at /;
X $pfx = '*' if /^panic/;
X }
X elsif (/^q/) {
X next if /^qqq /;
X }
X elsif (/^r/) {
X next if /^read /;
X next if /^revarp: Requesting/;
X next if /^root [od]/;
X }
X elsif (/^s/) {
X next if /^sc[0-9] at /;
X next if /^sd[0-9] at /;
X next if /^sd[0-9]: </;
X next if /^si[0-9] at /;
X next if /^si_getstatus/;
X next if /^sk[0-9] at /;
X next if /^skioctl/;
X next if /^skopen/;
X next if /^skprobe/;
X next if /^skread/;
X next if /^skwrite/;
X next if /^sky[0-9] at /;
X next if /^st[0-9] at /;
X next if /^st0:.*load/;
X next if /^stat1 = /;
X next if /^syncing disks/;
X next if /^syslogd: going down on signal 15/;
X }
X elsif (/^t/) {
X next if /^timeout [0-9]/;
X next if /^tm[0-9] at /;
X next if /^tod[0-9] at /;
X next if /^tv [0-9]/;
X $pfx = '*' if /^trap address/;
X }
X elsif (/^u/) {
X next if /^unit nsk/;
X next if /^use one of/;
X $pfx = '' if /^using/;
X next if /^using [0-9]+ buffers/;
X }
X elsif (/^x/) {
X next if /^xy[0-9] at /;
X next if /^write [0-9]/;
X next if /^xy[0-9]: </;
X next if /^xyc[0-9] at /;
X }
X elsif (/^y/) {
X next if /^yyy [0-9]/;
X }
X elsif (/^z/) {
X next if /^zs[0-9] at /;
X }
X $pfx = '*' if /^[a-z]+:$/;
X s/pid [0-9]+: //;
X if (/last message repeated ([0-9]+) time/) {
X $seen{$last} += $1;
X next;
X }
X s/^/$pfx/ if $pfx;
X unless ($seen{$_}++) {
X push(@seen,$_);
X }
X $last = $_;
X}
X$max = tell(Msgs);
X
Xopen(tmp,'|sort >oldmsgs.tmp') || die "Can't create tmp file.";
Xwhile ($_ = pop(@seen)) {
X print tmp $_;
X}
Xclose(tmp);
Xopen(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file.";
Xwhile (<tmp>) {
X if (/^nd:/) {
X next if $seen{$_} < 20;
X }
X if (/NFS/) {
X next if $seen{$_} < 20;
X }
X if (/no carrier/) {
X next if $seen{$_} < 20;
X }
X if (/silo overflow/) {
X next if $seen{$_} < 20;
X }
X print $seen{$_},":\t",$_;
X}
X
Xprint `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`;
!STUFFY!FUNK!
echo Extracting x2p/a2p.h
sed >x2p/a2p.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: a2p.h,v 2.0 88/06/05 00:15:33 root Exp $
X *
X * $Log: a2p.h,v $
X * Revision 2.0 88/06/05 00:15:33 root
X * Baseline version 2.0.
X *
X */
X
X#define VOIDUSED 1
X#include "../config.h"
X
X#ifndef BCOPY
X# define bcopy(s1,s2,l) memcpy(s2,s1,l);
X# define bzero(s,l) memset(s,0,l);
X#endif
X
X#include "handy.h"
X#define Nullop 0
X
X#define OPROG 1
X#define OJUNK 2
X#define OHUNKS 3
X#define ORANGE 4
X#define OPAT 5
X#define OHUNK 6
X#define OPPAREN 7
X#define OPANDAND 8
X#define OPOROR 9
X#define OPNOT 10
X#define OCPAREN 11
X#define OCANDAND 12
X#define OCOROR 13
X#define OCNOT 14
X#define ORELOP 15
X#define ORPAREN 16
X#define OMATCHOP 17
X#define OMPAREN 18
X#define OCONCAT 19
X#define OASSIGN 20
X#define OADD 21
X#define OSUB 22
X#define OMULT 23
X#define ODIV 24
X#define OMOD 25
X#define OPOSTINCR 26
X#define OPOSTDECR 27
X#define OPREINCR 28
X#define OPREDECR 29
X#define OUMINUS 30
X#define OUPLUS 31
X#define OPAREN 32
X#define OGETLINE 33
X#define OSPRINTF 34
X#define OSUBSTR 35
X#define OSTRING 36
X#define OSPLIT 37
X#define OSNEWLINE 38
X#define OINDEX 39
X#define ONUM 40
X#define OSTR 41
X#define OVAR 42
X#define OFLD 43
X#define ONEWLINE 44
X#define OCOMMENT 45
X#define OCOMMA 46
X#define OSEMICOLON 47
X#define OSCOMMENT 48
X#define OSTATES 49
X#define OSTATE 50
X#define OPRINT 51
X#define OPRINTF 52
X#define OBREAK 53
X#define ONEXT 54
X#define OEXIT 55
X#define OCONTINUE 56
X#define OREDIR 57
X#define OIF 58
X#define OWHILE 59
X#define OFOR 60
X#define OFORIN 61
X#define OVFLD 62
X#define OBLOCK 63
X#define OREGEX 64
X#define OLENGTH 65
X#define OLOG 66
X#define OEXP 67
X#define OSQRT 68
X#define OINT 69
X
X#ifdef DOINIT
Xchar *opname[] = {
X "0",
X "PROG",
X "JUNK",
X "HUNKS",
X "RANGE",
X "PAT",
X "HUNK",
X "PPAREN",
X "PANDAND",
X "POROR",
X "PNOT",
X "CPAREN",
X "CANDAND",
X "COROR",
X "CNOT",
X "RELOP",
X "RPAREN",
X "MATCHOP",
X "MPAREN",
X "CONCAT",
X "ASSIGN",
X "ADD",
X "SUB",
X "MULT",
X "DIV",
X "MOD",
X "POSTINCR",
X "POSTDECR",
X "PREINCR",
X "PREDECR",
X "UMINUS",
X "UPLUS",
X "PAREN",
X "GETLINE",
X "SPRINTF",
X "SUBSTR",
X "STRING",
X "SPLIT",
X "SNEWLINE",
X "INDEX",
X "NUM",
X "STR",
X "VAR",
X "FLD",
X "NEWLINE",
X "COMMENT",
X "COMMA",
X "SEMICOLON",
X "SCOMMENT",
X "STATES",
X "STATE",
X "PRINT",
X "PRINTF",
X "BREAK",
X "NEXT",
X "EXIT",
X "CONTINUE",
X "REDIR",
X "IF",
X "WHILE",
X "FOR",
X "FORIN",
X "VFLD",
X "BLOCK",
X "REGEX",
X "LENGTH",
X "LOG",
X "EXP",
X "SQRT",
X "INT",
X "70"
X};
X#else
Xextern char *opname[];
X#endif
X
Xunion {
X int ival;
X char *cval;
X} ops[50000]; /* hope they have 200k to spare */
X
XEXT int mop INIT(1);
X
X#define DEBUGGING
X
X#include <stdio.h>
X#include <ctype.h>
X
Xtypedef struct string STR;
Xtypedef struct htbl HASH;
X
X#include "str.h"
X#include "hash.h"
X
X/* A string is TRUE if not "" or "0". */
X#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1])))
XEXT char *Yes INIT("1");
XEXT char *No INIT("");
X
X#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 )))
X
X#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" )))
X#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
X#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str)))
XEXT STR *Str;
X
X#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
X
XSTR *str_new();
X
Xchar *scanpat();
Xchar *scannum();
X
Xvoid str_free();
X
XEXT int line INIT(0);
X
XEXT FILE *rsfp;
XEXT char buf[1024];
XEXT char *bufptr INIT(buf);
X
XEXT STR *linestr INIT(Nullstr);
X
XEXT char tokenbuf[256];
XEXT int expectterm INIT(TRUE);
X
X#ifdef DEBUGGING
XEXT int debug INIT(0);
XEXT int dlevel INIT(0);
X#define YYDEBUG 1
Xextern int yydebug;
X#endif
X
XEXT STR *freestrroot INIT(Nullstr);
X
XEXT STR str_no;
XEXT STR str_yes;
X
XEXT bool do_split INIT(FALSE);
XEXT bool split_to_array INIT(FALSE);
XEXT bool set_array_base INIT(FALSE);
XEXT bool saw_RS INIT(FALSE);
XEXT bool saw_OFS INIT(FALSE);
XEXT bool saw_ORS INIT(FALSE);
XEXT bool saw_line_op INIT(FALSE);
XEXT bool in_begin INIT(TRUE);
XEXT bool do_opens INIT(FALSE);
XEXT bool do_fancy_opens INIT(FALSE);
XEXT bool lval_field INIT(FALSE);
XEXT bool do_chop INIT(FALSE);
XEXT bool need_entire INIT(FALSE);
XEXT bool absmaxfld INIT(FALSE);
X
XEXT char const_FS INIT(0);
XEXT char *namelist INIT(Nullch);
XEXT char fswitch INIT(0);
X
XEXT int saw_FS INIT(0);
XEXT int maxfld INIT(0);
XEXT int arymax INIT(0);
Xchar *nameary[100];
X
XEXT STR *opens;
X
XEXT HASH *symtab;
!STUFFY!FUNK!
echo Extracting x2p/hash.c
sed >x2p/hash.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.c,v 2.0 88/06/05 00:15:50 root Exp $
X *
X * $Log: hash.c,v $
X * Revision 2.0 88/06/05 00:15:50 root
X * Baseline version 2.0.
X *
X */
X
X#include <stdio.h>
X#include "EXTERN.h"
X#include "handy.h"
X#include "util.h"
X#include "a2p.h"
X
XSTR *
Xhfetch(tb,key)
Xregister HASH *tb;
Xchar *key;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X
X if (!tb)
X return Nullstr;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X entry = tb->tbl_array[hash & tb->tbl_max];
X for (; entry; entry = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X return entry->hent_val;
X }
X return Nullstr;
X}
X
Xbool
Xhstore(tb,key,val)
Xregister HASH *tb;
Xchar *key;
XSTR *val;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X
X if (!tb)
X return FALSE;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X
X oentry = &(tb->tbl_array[hash & tb->tbl_max]);
X i = 1;
X
X for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X safefree((char*)entry->hent_val);
X entry->hent_val = val;
X return TRUE;
X }
X entry = (HENT*) safemalloc(sizeof(HENT));
X
X entry->hent_key = savestr(key);
X entry->hent_val = val;
X entry->hent_hash = hash;
X entry->hent_next = *oentry;
X *oentry = entry;
X
X if (i) { /* initial entry? */
X tb->tbl_fill++;
X if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT)
X hsplit(tb);
X }
X
X return FALSE;
X}
X
X#ifdef NOTUSED
Xbool
Xhdelete(tb,key)
Xregister HASH *tb;
Xchar *key;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X
X if (!tb)
X return FALSE;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X
X oentry = &(tb->tbl_array[hash & tb->tbl_max]);
X entry = *oentry;
X i = 1;
X for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X safefree((char*)entry->hent_val);
X safefree(entry->hent_key);
X *oentry = entry->hent_next;
X safefree((char*)entry);
X if (i)
X tb->tbl_fill--;
X return TRUE;
X }
X return FALSE;
X}
X#endif
X
Xhsplit(tb)
XHASH *tb;
X{
X int oldsize = tb->tbl_max + 1;
X register int newsize = oldsize * 2;
X register int i;
X register HENT **a;
X register HENT **b;
X register HENT *entry;
X register HENT **oentry;
X
X a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
X bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */
X tb->tbl_max = --newsize;
X tb->tbl_array = a;
X
X for (i=0; i<oldsize; i++,a++) {
X if (!*a) /* non-existent */
X continue;
X b = a+oldsize;
X for (oentry = a, entry = *a; entry; entry = *oentry) {
X if ((entry->hent_hash & newsize) != i) {
X *oentry = entry->hent_next;
X entry->hent_next = *b;
X if (!*b)
X tb->tbl_fill++;
X *b = entry;
X continue;
X }
X else
X oentry = &entry->hent_next;
X }
X if (!*a) /* everything moved */
X tb->tbl_fill--;
X }
X}
X
XHASH *
Xhnew()
X{
X register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
X
X tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
X tb->tbl_fill = 0;
X tb->tbl_max = 7;
X hiterinit(tb); /* so each() will start off right */
X bzero((char*)tb->tbl_array, 8 * sizeof(HENT*));
X return tb;
X}
X
X#ifdef NOTUSED
Xhshow(tb)
Xregister HASH *tb;
X{
X fprintf(stderr,"%5d %4d (%2d%%)\n",
X tb->tbl_max+1,
X tb->tbl_fill,
X tb->tbl_fill * 100 / (tb->tbl_max+1));
X}
X#endif
X
Xhiterinit(tb)
Xregister HASH *tb;
X{
X tb->tbl_riter = -1;
X tb->tbl_eiter = Null(HENT*);
X return tb->tbl_fill;
X}
X
XHENT *
Xhiternext(tb)
Xregister HASH *tb;
X{
X register HENT *entry;
X
X entry = tb->tbl_eiter;
X do {
X if (entry)
X entry = entry->hent_next;
X if (!entry) {
X tb->tbl_riter++;
X if (tb->tbl_riter > tb->tbl_max) {
X tb->tbl_riter = -1;
X break;
X }
X entry = tb->tbl_array[tb->tbl_riter];
X }
X } while (!entry);
X
X tb->tbl_eiter = entry;
X return entry;
X}
X
Xchar *
Xhiterkey(entry)
Xregister HENT *entry;
X{
X return entry->hent_key;
X}
X
XSTR *
Xhiterval(entry)
Xregister HENT *entry;
X{
X return entry->hent_val;
X}
!STUFFY!FUNK!
echo Extracting array.c
sed >array.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: array.c,v 2.0 88/06/05 00:08:17 root Exp $
X *
X * $Log: array.c,v $
X * Revision 2.0 88/06/05 00:08:17 root
X * Baseline version 2.0.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
XSTR *
Xafetch(ar,key)
Xregister ARRAY *ar;
Xint key;
X{
X if (key < 0 || key > ar->ary_fill)
X return Nullstr;
X return ar->ary_array[key];
X}
X
Xbool
Xastore(ar,key,val)
Xregister ARRAY *ar;
Xint key;
XSTR *val;
X{
X bool retval;
X
X if (key < 0)
X return FALSE;
X if (key > ar->ary_max) {
X int newmax = key + ar->ary_max / 5;
X
X ar->ary_array = (STR**)saferealloc((char*)ar->ary_array,
X (newmax+1) * sizeof(STR*));
X bzero((char*)&ar->ary_array[ar->ary_max+1],
X (newmax - ar->ary_max) * sizeof(STR*));
X ar->ary_max = newmax;
X }
X while (ar->ary_fill < key) {
X if (++ar->ary_fill < key && ar->ary_array[ar->ary_fill] != Nullstr) {
X str_free(ar->ary_array[ar->ary_fill]);
X ar->ary_array[ar->ary_fill] = Nullstr;
X }
X }
X retval = (ar->ary_array[key] != Nullstr);
X if (retval)
X str_free(ar->ary_array[key]);
X ar->ary_array[key] = val;
X return retval;
X}
X
Xbool
Xadelete(ar,key)
Xregister ARRAY *ar;
Xint key;
X{
X if (key < 0 || key > ar->ary_max)
X return FALSE;
X if (ar->ary_array[key]) {
X str_free(ar->ary_array[key]);
X ar->ary_array[key] = Nullstr;
X return TRUE;
X }
X return FALSE;
X}
X
XARRAY *
Xanew(stab)
XSTAB *stab;
X{
X register ARRAY *ar = (ARRAY*)safemalloc(sizeof(ARRAY));
X
X ar->ary_array = (STR**) safemalloc(5 * sizeof(STR*));
X ar->ary_magic = str_new(0);
X ar->ary_magic->str_link.str_magic = stab;
X ar->ary_fill = -1;
X ar->ary_index = -1;
X ar->ary_max = 4;
X bzero((char*)ar->ary_array, 5 * sizeof(STR*));
X return ar;
X}
X
Xvoid
Xaclear(ar)
Xregister ARRAY *ar;
X{
X register int key;
X
X if (!ar)
X return;
X for (key = 0; key <= ar->ary_max; key++)
X str_free(ar->ary_array[key]);
X ar->ary_fill = -1;
X bzero((char*)ar->ary_array, (ar->ary_max+1) * sizeof(STR*));
X}
X
Xvoid
Xafree(ar)
Xregister ARRAY *ar;
X{
X register int key;
X
X if (!ar)
X return;
X for (key = 0; key <= ar->ary_max; key++)
X str_free(ar->ary_array[key]);
X str_free(ar->ary_magic);
X safefree((char*)ar->ary_array);
X safefree((char*)ar);
X}
X
Xbool
Xapush(ar,val)
Xregister ARRAY *ar;
XSTR *val;
X{
X return astore(ar,++(ar->ary_fill),val);
X}
X
XSTR *
Xapop(ar)
Xregister ARRAY *ar;
X{
X STR *retval;
X
X if (ar->ary_fill < 0)
X return Nullstr;
X retval = ar->ary_array[ar->ary_fill];
X ar->ary_array[ar->ary_fill--] = Nullstr;
X return retval;
X}
X
Xaunshift(ar,num)
Xregister ARRAY *ar;
Xregister int num;
X{
X register int i;
X register STR **sstr,**dstr;
X
X if (num <= 0)
X return;
X astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */
X dstr = ar->ary_array + ar->ary_fill;
X sstr = dstr - num;
X for (i = ar->ary_fill; i >= 0; i--) {
X *dstr-- = *sstr--;
X }
X bzero((char*)(ar->ary_array), num * sizeof(STR*));
X}
X
XSTR *
Xashift(ar)
Xregister ARRAY *ar;
X{
X STR *retval;
X
X if (ar->ary_fill < 0)
X return Nullstr;
X retval = ar->ary_array[0];
X bcopy((char*)(ar->ary_array+1),(char*)ar->ary_array,
X ar->ary_fill * sizeof(STR*));
X ar->ary_array[ar->ary_fill--] = Nullstr;
X return retval;
X}
X
Xint
Xalen(ar)
Xregister ARRAY *ar;
X{
X return ar->ary_fill;
X}
X
Xafill(ar, fill)
Xregister ARRAY *ar;
Xint fill;
X{
X if (fill < 0)
X fill = -1;
X if (fill <= ar->ary_max)
X ar->ary_fill = fill;
X else
X astore(ar,fill,Nullstr);
X}
X
Xvoid
Xajoin(ar,delim,str)
Xregister ARRAY *ar;
Xchar *delim;
Xregister STR *str;
X{
X register int i;
X register int len;
X register int dlen;
X
X if (ar->ary_fill < 0) {
X str_set(str,"");
X STABSET(str);
X return;
X }
X dlen = strlen(delim);
X len = ar->ary_fill * dlen; /* account for delimiters */
X for (i = ar->ary_fill; i >= 0; i--)
X len += str_len(ar->ary_array[i]);
X str_grow(str,len); /* preallocate for efficiency */
X str_sset(str,ar->ary_array[0]);
X for (i = 1; i <= ar->ary_fill; i++) {
X str_ncat(str,delim,dlen);
X str_scat(str,ar->ary_array[i]);
X }
X STABSET(str);
X}
!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
Xecho "Extracting Makefile (with variable substitutions)"
Xcat >Makefile <<!GROK!THIS!
X# $Header: Makefile.SH,v 2.0 88/06/05 00:07:54 root Exp $
X#
X# $Log: Makefile.SH,v $
X# Revision 2.0 88/06/05 00:07:54 root
X# Baseline version 2.0.
X#
X#
X
XCC = $cc
Xbin = $bin
Xlib = $privlib
Xmansrc = $mansrc
Xmanext = $manext
XCFLAGS = $ccflags -O
XLDFLAGS = $ldflags
XSMALL = $small
XLARGE = $large $split
Xmallocsrc = $mallocsrc
Xmallocobj = $mallocobj
XSLN = $sln
X
Xlibs = $libnm -lm
X!GROK!THIS!
X
Xcat >>Makefile <<'!NO!SUBS!'
X
Xpublic = perl perldb
X
Xprivate =
X
Xmanpages = perl.man perldb.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 regexp.h spat.h stab.h str.h util.h
X
Xh = $(h1) $(h2)
X
Xc1 = arg.c array.c cmd.c dump.c eval.c form.c hash.c $(mallocsrc)
Xc2 = perly.c regexp.c stab.c str.c toke.c util.c version.c
X
Xc = $(c1) $(c2)
X
Xobj1 = arg.o array.o cmd.o dump.o eval.o form.o hash.o $(mallocobj)
Xobj2 = perly.o regexp.o stab.o str.o toke.o util.o version.o
X
Xobj = $(obj1) $(obj2)
X
Xlintflags = -phbvxac
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)
X touch all
X
Xperl: $(obj) perl.o
X $(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl
X
Xperl.c perly.h: perl.y
X @ echo Expect 37 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 config.h
X $(CC) -c $(CFLAGS) $(LARGE) perl.c
X
X# if a .h file depends on another .h file...
X$(h):
X touch $@
X
Xperl.man: perl.man.1 perl.man.2
X cat perl.man.1 perl.man.2 >perl.man
X
Xinstall: perl perl.man
X# won't work with csh
X export PATH || exit 1
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 - 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 chmod +x makedir
X - ./makedir $(lib)
X - \
Xif test `pwd` != $(lib); then \
Xcp $(private) lib/*.pl $(lib); \
Xfi
X# cd $(lib); \
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
Xclean:
X rm -f *.o
X
Xrealclean:
X rm -f perl *.orig */*.orig *.o core $(addedbyconf)
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
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
X$(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 cmd.h
sed >cmd.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: cmd.h,v 2.0 88/06/05 00:08:28 root Exp $
X *
X * $Log: cmd.h,v $
X * Revision 2.0 88/06/05 00:08:28 root
X * Baseline version 2.0.
X *
X */
X
X#define C_NULL 0
X#define C_IF 1
X#define C_WHILE 2
X#define C_EXPR 3
X#define C_BLOCK 4
X
X#ifdef DEBUGGING
X#ifndef DOINIT
Xextern char *cmdname[];
X#else
Xchar *cmdname[] = {
X "NULL",
X "IF",
X "WHILE",
X "EXPR",
X "BLOCK",
X "5",
X "6",
X "7",
X "8",
X "9",
X "10",
X "11",
X "12",
X "13",
X "14",
X "15",
X "16"
X};
X#endif
X#endif /* DEBUGGING */
X
X#define CF_OPTIMIZE 077 /* type of optimization */
X#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
X#define CF_NESURE 0200 /* if short doesn't match we're sure */
X#define CF_EQSURE 0400 /* if short does match we're sure */
X#define CF_COND 01000 /* test c_expr as conditional first, if not null. */
X /* Set for everything except do {} while currently */
X#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */
X#define CF_INVERT 04000 /* it's an "unless" or an "until" */
X#define CF_ONCE 010000 /* we've already pushed the label on the stack */
X#define CF_FLIP 020000 /* on a match do flipflop */
X
X#define CFT_FALSE 0 /* c_expr is always false */
X#define CFT_TRUE 1 /* c_expr is always true */
X#define CFT_REG 2 /* c_expr is a simple register */
X#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */
X#define CFT_STROP 4 /* c_expr is a string comparison */
X#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */
X#define CFT_GETS 6 /* c_expr is <filehandle> */
X#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */
X#define CFT_UNFLIP 8 /* 2nd half of range not optimized */
X#define CFT_CHOP 9 /* c_expr is a chop on a register */
X#define CFT_ARRAY 10 /* this is a foreach loop */
X#define CFT_INDGETS 11 /* c_expr is <$variable> */
X#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
X
X#ifdef DEBUGGING
X#ifndef DOINIT
Xextern char *cmdopt[];
X#else
Xchar *cmdopt[] = {
X "FALSE",
X "TRUE",
X "REG",
X "ANCHOR",
X "STROP",
X "SCAN",
X "GETS",
X "EVAL",
X "UNFLIP",
X "CHOP",
X "ARRAY",
X "INDGETS",
X "NUMOP",
X "13"
X};
X#endif
X#endif /* DEBUGGING */
X
Xstruct acmd {
X STAB *ac_stab; /* a symbol table entry */
X ARG *ac_expr; /* any associated expression */
X};
X
Xstruct ccmd {
X CMD *cc_true; /* normal code to do on if and while */
X CMD *cc_alt; /* else code or continue code */
X};
X
Xstruct cmd {
X CMD *c_next; /* the next command at this level */
X ARG *c_expr; /* conditional expression */
X CMD *c_head; /* head of this command list */
X STR *c_short; /* string to match as shortcut */
X STAB *c_stab; /* a symbol table entry, mostly for fp */
X SPAT *c_spat; /* pattern used by optimization */
X char *c_label; /* label for this construct */
X union ucmd {
X struct acmd acmd; /* normal command */
X struct ccmd ccmd; /* compound command */
X } ucmd;
X short c_slen; /* len of c_short, if not null */
X short c_flags; /* optimization flags--see above */
X char *c_file; /* file the following line # is from */
X line_t c_line; /* line # of this command */
X char c_type; /* what this command does */
X};
X
X#define Nullcmd Null(CMD*)
X
XEXT CMD *main_root INIT(Nullcmd);
XEXT CMD *eval_root INIT(Nullcmd);
X
XEXT struct compcmd {
X CMD *comp_true;
X CMD *comp_alt;
X};
X
Xvoid opt_arg();
Xvoid evalstatic();
XSTR *cmd_exec();
!STUFFY!FUNK!
echo Extracting t/comp.cmdopt
sed >t/comp.cmdopt <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: comp.cmdopt,v 2.0 88/06/05 00:12:34 root Exp $
X
Xprint "1..40\n";
X
X# test the optimization of constants
X
Xif (1) { print "ok 1\n";} else { print "not ok 1\n";}
Xunless (0) { print "ok 2\n";} else { print "not ok 2\n";}
X
Xif (0) { print "not ok 3\n";} else { print "ok 3\n";}
Xunless (1) { print "not ok 4\n";} else { print "ok 4\n";}
X
Xunless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
Xif (!0) { print "ok 6\n";} else { print "not ok 6\n";}
X
Xunless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
Xif (!1) { print "not ok 8\n";} else { print "ok 8\n";}
X
X$x = 1;
Xif (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
Xif (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
X$x = '';
Xif (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
Xif (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
X
X$x = 1;
Xif (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
Xif (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
X$x = '';
Xif (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
Xif (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
X
X
X# test the optimization of registers
X
X$x = 1;
Xif ($x) { print "ok 17\n";} else { print "not ok 17\n";}
Xunless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
X
X$x = '';
Xif ($x) { print "not ok 19\n";} else { print "ok 19\n";}
Xunless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
X
X# test optimization of string operations
X
X$a = 'a';
Xif ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
Xif ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
X
Xif ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
Xif ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
X# test interaction of logicals and other operations
X
X$a = 'a';
X$x = 1;
Xif ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
Xif ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
X$x = '';
Xif ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
Xif ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
X
X$x = 1;
Xif ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
Xif ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
X$x = '';
Xif ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
Xif ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
X
X$x = 1;
Xif ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
Xif ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
X$x = '';
Xif ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
X if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
X
X$x = 1;
Xif ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
Xif ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
X$x = '';
Xif ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
Xif ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
!STUFFY!FUNK!
echo Extracting perldb.man
sed >perldb.man <<'!STUFFY!FUNK!' -e 's/X//'
X.rn '' }`
X''' $Header: perldb.man,v 2.0 88/06/05 00:09:50 root Exp $
X'''
X''' $Log: perldb.man,v $
X''' Revision 2.0 88/06/05 00:09:50 root
X''' Baseline version 2.0.
X'''
X'''
X.de Sh
X.br
X.ne 5
X.PP
X\fB\\$1\fR
X.PP
X..
X.de Sp
X.if t .sp .5v
X.if n .sp
X..
X.de Ip
X.br
X.ie \\n.$>=3 .ne \\$3
X.el .ne 3
X.IP "\\$1" \\$2
X..
X'''
X''' Set up \*(-- to give an unbreakable dash;
X''' string Tr holds user defined translation string.
X''' Bell System Logo is used as a dummy character.
X'''
X.tr \(*W-|\(bv\*(Tr
X.ie n \{\
X.ds -- \(*W-
X.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
X.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
X.ds L" ""
X.ds R" ""
X.ds L' '
X.ds R' '
X'br\}
X.el\{\
X.ds -- \(em\|
X.tr \*(Tr
X.ds L" ``
X.ds R" ''
X.ds L' `
X.ds R' '
X'br\}
X.TH PERLDB 1 LOCAL
X.SH NAME
Xperldb - Perl Debugger
X.SH SYNOPSIS
X.B perldb [-o output] perlscript arguments
X.SH DESCRIPTION
X.I Perldb
Xis a symbolic debugger for
X.I perl
Xscripts.
XRun your script just as you normally would, only prepend \*(L"perldb\*(R" to
Xthe command.
X(On systems where #! doesn't work, put any perl switches into the #! line
Xanyway\*(--perldb will pass them off to perl when it runs the script.)
XPerldb copies your script to a temporary file, instrumenting it in the process
Xand adding a debugging monitor.
XIt then executes the instrumented script for
Xyou and stops at the first statement so you can set any breakpoints or actions
Xyou desire.
X.PP
XThere is only one switch: \-o, which tells perldb to put its temporary file
Xin the filename you specify, and to refrain from deleting the file.
XUse this switch if you intend to rerun the instrumented script, or want to
Xlook at it for some reason.
X.PP
XThese are the debugging commands:
X.Ip s 8
XSingle step.
XSubsequent carriage returns will single step.
X.Ip c 8
XContinue.
XTurns off single step mode and runs till the next break point.
XSubsequent carriage returns will continue.
X.Ip <CR> 8
XRepeat last s or c.
X.Ip "l min-max" 8
XList lines in the indicated range.
X.Ip "l line" 8
XList indicated line.
X.Ip l 8
XList the whole program.
X.Ip L 8
XList breakpoints.
X.Ip t 8
XToggle trace mode.
XTrace mode causes lines to be printed out as they are executed.
X.Ip "b line" 8
XSet breakpoint at indicated line.
X.Ip "d line" 8
XDelete breakpoint at indicated line.
X.Ip d 8
XDelete breakpoint at this line.
X.Ip "a line command" 8
XSet an action for indicated line.
XThe command must be a valid perl command, except that a missing trailing ;
Xwill be supplied.
X.Ip q 8
XQuit.
X.Ip command 8
XExecute command as a perl statement.
XA missing trailing ; will be supplied if necessary.
X.SH ENVIRONMENT
XNo environment variables are used by perldb.
X.SH AUTHOR
XLarry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
X.SH FILES
X/tmp/pdb$$ temporary file for instrumented script
X.SH SEE ALSO
Xperl
X.SH DIAGNOSTICS
X.SH BUGS
X.rn }` ''
!STUFFY!FUNK!
echo Extracting Changes
sed >Changes <<'!STUFFY!FUNK!' -e 's/X//'
XNew regexp routines derived from Henry Spencer's.
X Support for /(foo|bar)/.
X Support for /(foo)*/ and /(foo)+/.
X \s for whitespace, \S nonwhitespace
X \d for digit, \D nondigit
X
XLocal variables in blocks, subroutines and evals.
X
XRecursive subroutine calls are now supported.
X
XArray values may now be interpolated into lists:
X unlink 'foo', 'bar', @trashcan, 'tmp';
X
XFile globbing via <*.foo>.
X
XUse of <> in array contexts returns the whole file or glob list:
X unlink <*.foo>;
X
XNew iterator for normal arrays, foreach, that allows both read and write:
X foreach $elem ($array) {
X $elem =~ s/foo/bar/;
X }
X
XAbility to open pipe to a forked off script for secure pipes in setuid scripts.
X
XFile inclusion via
X do 'foo.pl';
X
XMore file tests, including -t to see if, for instance, stdin is
Xa terminal. File tests now behave in a more correct manner. You can do
Xfile tests on filehandles as well as filenames. The special filetests
X-T and -B test a file to see if it's text or binary.
X
XAn eof can now be used on each file of the <> input for such purposes
Xas resetting the line numbers or appending to each file of an inplace edit.
X
XAssignments can now function as lvalues, so you can say things like
X ($HOST = $host) =~ tr/a-z/A-Z/;
X ($obj = $src) =~ s/\.c$/.o/;
X
XYou can now do certain file operations with a variable which holds the name
Xof a filehandle, e.g. open(++$incl,$includefilename); $foo = <$incl>;
X
XYou can now a subroutine indirectly through a scalar variable:
X $which = 'xyz';
X do $which('foo'); # calls xyz
X
XWarnings are now available (with -w) on use of uninitialized variables and on
Xidentifiers that are mentioned only once, and on reference to various
Xundefined things.
X
XThe -S switch causes perl to search the PATH for the script so that you can say
X eval "exec /usr/bin/perl -S $0 $*"
X if $running_under_some_shell;
X
XReset now resets arrays and associative arrays as well as string variables.
X
XAssigning off the end of an array now nulls out any intervening values.
X
X$#foo is now an lvalue. You can preallocate or truncate arrays, or recover
Xvalues lost to prior truncation.
X
X$#foo is now indexed to $[ properly.
X
Xs/foo/bar/i optimization bug fixed.
X
XThe $x = "...$x..."; bug is fixed.
X
XThe @ary = (1); bug is now fixed. You can even say @ary = 1;
X
X$= now returns the correct value.
X
XSeveral of the larger files are now split into smaller pieces for easier
Xcompilation.
X
XPattern matches evaluated in an array context now return ($1, $2...).
X
XThere is now a wait operator.
X
XThere is now a sort operator.
X
XThe requirement of parens around certain expressions when taking their value
Xhas been lifted. In particular, you can say
X $x = print "foo","bar";
X $x = unlink "foo","bar";
X chdir "foo" || die "Can't chdir to foo\n";
X
XThe manual is now not lying when it says that perl is generally faster than
Xsed. I hope.
!STUFFY!FUNK!
echo Extracting config.H
sed >config.H <<'!STUFFY!FUNK!' -e 's/X//'
X/* config.h
X * This file was produced by running the config.h.SH script, which
X * gets its values from config.sh, which is generally produced by
X * running Configure.
X *
X * Feel free to modify any of this as the need arises. Note, however,
X * that running config.h.SH again will wipe out any changes you've made.
X * For a more permanent change edit config.sh and rerun config.h.SH.
X */
X
X
X/* EUNICE:
X * This symbol, if defined, indicates that the program is being compiled
X * under the EUNICE package under VMS. The program will need to handle
X * things like files that don't go away the first time you unlink them,
X * due to version numbering. It will also need to compensate for lack
X * of a respectable link() command.
X */
X/* VMS:
X * This symbol, if defined, indicates that the program is running under
X * VMS. It is currently only set in conjunction with the EUNICE symbol.
X */
X#/*undef EUNICE /**/
X#/*undef VMS /**/
X
X/* CHARSPRINTF:
X * This symbol is defined if this system declares "char *sprintf()" in
X * stdio.h. The trend seems to be to declare it as "int sprintf()". It
X * is up to the package author to declare sprintf correctly based on the
X * symbol.
X */
X#define CHARSPRINTF /**/
X
X/* index:
X * This preprocessor symbol is defined, along with rindex, if the system
X * uses the strchr and strrchr routines instead.
X */
X/* rindex:
X * This preprocessor symbol is defined, along with index, if the system
X * uses the strchr and strrchr routines instead.
X */
X#/*undef index strchr /* cultural */
X#/*undef rindex strrchr /* differences? */
X
X/* STRUCTCOPY:
X * This symbol, if defined, indicates that this C compiler knows how
X * to copy structures. If undefined, you'll need to use a block copy
X * routine of some sort instead.
X */
X#define STRUCTCOPY /**/
X
X/* vfork:
X * This symbol, if defined, remaps the vfork routine to fork if the
X * vfork() routine isn't supported here.
X */
X#/*undef vfork fork /**/
X
X/* VOIDFLAGS:
X * This symbol indicates how much support of the void type is given by this
X * compiler. What various bits mean:
X *
X * 1 = supports declaration of void
X * 2 = supports arrays of pointers to functions returning void
X * 4 = supports comparisons between pointers to void functions and
X * addresses of void functions
X *
X * The package designer should define VOIDUSED to indicate the requirements
X * of the package. This can be done either by #defining VOIDUSED before
X * including config.h, or by defining defvoidused in Myinit.U. If the
X * level of void support necessary is not present, defines void to int.
X */
X#ifndef VOIDUSED
X#define VOIDUSED 7
X#endif
X#define VOIDFLAGS 7
X#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
X#define void int /* is void to be avoided? */
X#define M_VOID /* Xenix strikes again */
X#endif
X
!STUFFY!FUNK!
echo Extracting t/re_tests
sed >t/re_tests <<'!STUFFY!FUNK!' -e 's/X//'
Xabc abc y $& abc
Xabc xbc n - -
Xabc axc n - -
Xabc abx n - -
Xabc xabcy y $& abc
Xabc ababc y $& abc
Xab*c abc y $& abc
Xab*bc abc y $& abc
Xab*bc abbc y $& abbc
Xab*bc abbbbc y $& abbbbc
Xab+bc abbc y $& abbc
Xab+bc abc n - -
Xab+bc abq n - -
Xab+bc abbbbc y $& abbbbc
Xab?bc abbc y $& abbc
Xab?bc abc y $& abc
Xab?bc abbbbc n - -
Xab?c abc y $& abc
X^abc$ abc y $& abc
X^abc$ abcc n - -
X^abc abcc y $& abc
X^abc$ aabc n - -
Xabc$ aabc y $& abc
X^ abc y $&
X$ abc y $&
Xa.c abc y $& abc
Xa.c axc y $& axc
Xa.*c axyzc y $& axyzc
Xa.*c axyzd n - -
Xa[bc]d abc n - -
Xa[bc]d abd y $& abd
Xa[b-d]e abd n - -
Xa[b-d]e ace y $& ace
Xa[b-d] aac y $& ac
Xa[-b] a- y $& a-
Xa[b-] a- y $& a-
Xa[b-a] - c - -
Xa[]b - c - -
Xa[ - c - -
Xa] a] y $& a]
Xa[]]b a]b y $& a]b
Xa[^bc]d aed y $& aed
Xa[^bc]d abd n - -
Xa[^-b]c adc y $& adc
Xa[^-b]c a-c n - -
Xa[^]b]c a]c n - -
Xa[^]b]c adc y $& adc
Xab|cd abc y $& ab
Xab|cd abcd y $& ab
X()ef def y $&-$1 ef-
X()* - c - -
X*a - c - -
X^* - c - -
X$* - c - -
X(*)b - c - -
X$b b n - -
Xa\ - c - -
Xa\(b a(b y $&-$1 a(b-
Xa\(*b ab y $& ab
Xa\(*b a((b y $& a((b
Xa\\b a\b y $& a\b
Xabc) - c - -
X(abc - c - -
X((a)) abc y $&-$1-$2 a-a-a
X(a)b(c) abc y $&-$1-$2 abc-a-c
Xa+b+c aabbabc y $& abc
Xa** - c - -
Xa*? - c - -
X(a*)* - c - -
X(a*)+ - c - -
X(a|)* - c - -
X(a*|b)* - c - -
X(a+|b)* ab y $&-$1 ab-b
X(a+|b)+ ab y $&-$1 ab-b
X(a+|b)? ab y $&-$1 a-a
X(^)* - c - -
X(ab|)* - c - -
X)( - c - -
X[^ab]* cde y $& cde
Xabc n - -
Xa* y $&
X([abc])*d abbbcd y $&-$1 abbbcd-c
X([abc])*bcd abcd y $&-$1 abcd-a
Xa|b|c|d|e e y $& e
X(a|b|c|d|e)f ef y $&-$1 ef-e
X((a*|b))* - c - -
Xabcd*efg abcdefg y $& abcdefg
Xab* xabyabbbz y $& ab
Xab* xayabbbz y $& a
X(ab|cd)e abcde y $&-$1 cde-cd
X[abhgefdc]ij hij y $& hij
X^(ab|cd)e abcde n x$1y xy
X(abc|)ef abcdef y $&-$1 ef-
X(a|b)c*d abcd y $&-$1 bcd-b
X(ab|ab*)bc abc y $&-$1 abc-a
Xa([bc]*)c* abc y $&-$1 abc-bc
Xa([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
Xa([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
Xa([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
Xa[bcd]*dcdcde adcdcde y $& adcdcde
Xa[bcd]+dcdcde adcdcde n - -
X(ab|a)b*c abc y $&-$1 abc-ab
X((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
X[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
X^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
X(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
X(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
X(bc+d$|ef*g.|h?i(j|k)) effg n - -
X(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
X(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
X((((((((((a)))))))))) - c - -
X(((((((((a))))))))) a y $& a
Xmultiple words of text uh-uh n - -
Xmultiple words multiple words, yeah y $& multiple words
X(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
X\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
X[k] ab n - -
Xabcd abcd y $&-\$&-\\$& abcd-$&-\abcd
Xa(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc
Xa[-]?c ac y $& ac
X(abc)\1 abcabc y $1 abc
X([a-c]*)\1 abcabc y $1 abc
!STUFFY!FUNK!
echo Extracting t/io.tell
sed >t/io.tell <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: io.tell,v 2.0 88/06/05 00:13:14 root Exp $
X
Xprint "1..13\n";
X
X$TST = 'tst';
X
Xopen($TST, '../Makefile') || (die "Can't open ../Makefile");
X
Xif (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
X
X$firstline = <$TST>;
X$secondpos = tell;
X
X$x = 0;
Xwhile (<tst>) {
X if (eof) {$x++;}
X}
Xif ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
X
X$lastpos = tell;
X
Xunless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
X
Xif (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
X
Xif (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
X
Xif ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
X
Xif ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
X
Xif (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
X
Xif (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
X
Xif ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
X
Xif (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
X
Xif ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
X
Xunless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
!STUFFY!FUNK!
echo ""
echo "End of kit 13 (of 15)"
cat /dev/null >kit13isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15; 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.