perl 3.0 beta kit [19/23]
Larry Wall
lwall at jato.Jpl.Nasa.Gov
Mon Sep 4 05:00:16 AEST 1989
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 23 through sh. When all 23 kits have been run, read README.
echo "This is perl 3.0 kit 19 (of 23). If kit 19 is complete, the line"
echo '"'"End of kit 19 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir t x2p 2>/dev/null
echo Extracting form.c
sed >form.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: form.c,v 2.0.1.3 88/11/22 01:07:10 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: form.c,v $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X/* Forms stuff */
X
Xvoid
Xform_parseargs(fcmd)
Xregister FCMD *fcmd;
X{
X register int i;
X register ARG *arg;
X register int items;
X STR *str;
X ARG *parselist();
X line_t oldline = line;
X int oldsave = savestack->ary_fill;
X
X str = fcmd->f_unparsed;
X line = fcmd->f_line;
X fcmd->f_unparsed = Nullstr;
X (void)savehptr(&curstash);
X curstash = str->str_u.str_hash;
X arg = parselist(str);
X restorelist(oldsave);
X
X items = arg->arg_len - 1; /* ignore $$ on end */
X for (i = 1; i <= items; i++) {
X if (!fcmd || fcmd->f_type == F_NULL)
X fatal("Too many field values");
X dehoist(arg,i);
X fcmd->f_expr = make_op(O_ITEM,1,
X arg[i].arg_ptr.arg_arg,Nullarg,Nullarg,0);
X if (fcmd->f_flags & FC_CHOP) {
X if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
X fcmd->f_expr[1].arg_type = A_LVAL;
X else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
X fcmd->f_expr[1].arg_type = A_LEXPR;
X else
X fatal("^ field requires scalar lvalue");
X }
X fcmd = fcmd->f_next;
X }
X if (fcmd && fcmd->f_type)
X fatal("Not enough field values");
X line = oldline;
X Safefree(arg);
X str_free(str);
X}
X
Xint newsize;
X
X#define CHKLEN(allow) \
Xnewsize = (d - orec->o_str) + (allow); \
Xif (newsize >= curlen) { \
X curlen = d - orec->o_str; \
X GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
X d = orec->o_str + curlen; /* in case it moves */ \
X curlen = orec->o_len - 2; \
X}
X
Xformat(orec,fcmd,sp)
Xregister struct outrec *orec;
Xregister FCMD *fcmd;
Xint sp;
X{
X register char *d = orec->o_str;
X register char *s;
X register int curlen = orec->o_len - 2;
X register int size;
X char tmpchar;
X char *t;
X CMD mycmd;
X STR *str;
X char *chophere;
X
X mycmd.c_type = C_NULL;
X orec->o_lines = 0;
X for (; fcmd; fcmd = fcmd->f_next) {
X CHKLEN(fcmd->f_presize);
X if (s = fcmd->f_pre) {
X while (*s) {
X if (*s == '\n') {
X while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
X d--;
X if (fcmd->f_flags & FC_NOBLANK &&
X (d == orec->o_str || d[-1] == '\n') ) {
X orec->o_lines--; /* don't print blank line */
X break;
X }
X }
X *d++ = *s++;
X }
X }
X if (fcmd->f_unparsed)
X form_parseargs(fcmd);
X switch (fcmd->f_type) {
X case F_NULL:
X orec->o_lines++;
X break;
X case F_LEFT:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (index(chopset,(*d++ = *s++)))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X d -= (s - chophere);
X if (fcmd->f_flags & FC_MORE &&
X *chophere && strNE(chophere,"\n")) {
X while (size < 3) {
X d--;
X size++;
X }
X while (d[-1] == ' ' && size < fcmd->f_size) {
X d--;
X size++;
X }
X *d++ = '.';
X *d++ = '.';
X *d++ = '.';
X }
X while (index(chopset,*chophere))
X chophere++;
X str_chop(str,chophere);
X }
X if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
X size = 0; /* no spaces before newline */
X while (size) {
X size--;
X *d++ = ' ';
X }
X break;
X case F_RIGHT:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X t = s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (index(chopset,*s++))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X s = chophere;
X while (index(chopset,*chophere))
X chophere++;
X }
X tmpchar = *s;
X *s = '\0';
X while (size) {
X size--;
X *d++ = ' ';
X }
X size = s - t;
X (void)bcopy(t,d,size);
X d += size;
X *s = tmpchar;
X if (fcmd->f_flags & FC_CHOP)
X str_chop(str,chophere);
X break;
X case F_CENTER: {
X int halfsize;
X
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X t = s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (index(chopset,*s++))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X s = chophere;
X while (index(chopset,*chophere))
X chophere++;
X }
X tmpchar = *s;
X *s = '\0';
X halfsize = size / 2;
X while (size > halfsize) {
X size--;
X *d++ = ' ';
X }
X size = s - t;
X (void)bcopy(t,d,size);
X d += size;
X *s = tmpchar;
X if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
X size = 0; /* no spaces before newline */
X else
X size = halfsize;
X while (size) {
X size--;
X *d++ = ' ';
X }
X if (fcmd->f_flags & FC_CHOP)
X str_chop(str,chophere);
X break;
X }
X case F_LINES:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X s = str_get(str);
X size = str_len(str);
X CHKLEN(size);
X orec->o_lines += countlines(s);
X (void)bcopy(s,d,size);
X d += size;
X break;
X }
X }
X *d++ = '\0';
X}
X
Xcountlines(s)
Xregister char *s;
X{
X register int count = 0;
X
X while (*s) {
X if (*s++ == '\n')
X count++;
X }
X return count;
X}
X
Xdo_write(orec,stio,sp)
Xstruct outrec *orec;
Xregister STIO *stio;
Xint sp;
X{
X FILE *ofp = stio->ofp;
X
X#ifdef DEBUGGING
X if (debug & 256)
X fprintf(stderr,"left=%ld, todo=%ld\n",
X (long)stio->lines_left, (long)orec->o_lines);
X#endif
X if (stio->lines_left < orec->o_lines) {
X if (!stio->top_stab) {
X STAB *topstab;
X
X if (!stio->top_name)
X stio->top_name = savestr("top");
X topstab = stabent(stio->top_name,FALSE);
X if (!topstab || !stab_form(topstab)) {
X stio->lines_left = 100000000;
X goto forget_top;
X }
X stio->top_stab = topstab;
X }
X if (stio->lines_left >= 0 && stio->page > 0)
X (void)putc('\f',ofp);
X stio->lines_left = stio->page_len;
X stio->page++;
X format(&toprec,stab_form(stio->top_stab),sp);
X fputs(toprec.o_str,ofp);
X stio->lines_left -= toprec.o_lines;
X }
X forget_top:
X fputs(orec->o_str,ofp);
X stio->lines_left -= orec->o_lines;
X}
!STUFFY!FUNK!
echo Extracting Changes
sed >Changes <<'!STUFFY!FUNK!' -e 's/X//'
XChanges to perl
X---------------
X
XApart from little bug fixes, here are the new features:
X
XPerl can now handle binary data correctly and has functions to pack and
Xunpack binary structures into arrays or lists. You can now do arbitrary
Xioctl functions.
X
XYou can do i/o with sockets and select.
X
XYou can now write packages with their own namespace.
X
XYou can now pass arrays and such to subroutines by reference.
X
XThe debugger now has hooks in the perl parser so it doesn't get confused.
XThe debugger won't interfere with stdin and stdout. New debugger commands:
X n Single step around subroutine call.
X l min+incr List incr+1 lines starting at min.
X l List incr+1 more lines.
X l subname List subroutine.
X b subname Set breakpoint at first line of subroutine.
X S List subroutine names.
X D Delete all breakpoints.
X A List line actions.
X < command Define command before prompt.
X > command Define command after prompt.
X ! number Redo command (default previous command).
X ! -number Redo numberth to last command.
X h -number Display last number commands (default all).
X p expr Same as \"print DBout expr\".
X
XThe rules are more consistent about where parens are needed and
Xwhere they are not. In particular, unary operators and list operators now
Xbehave like functions if they're called like functions.
X
XThere are some new quoting mechanisms:
X $foo = q/"'"'"'"'"'"'"/;
X $foo = qq/"'"''$bar"''/;
X $foo = q(hi there);
X $foo = <<'EOF' x 10;
X Why, it's the old here-is mechanism!
X EOF
X
XYou can now work with array slices (note the initial @):
X @foo[1,2,3];
X @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = (1,2,3,4,5,6,7);
X @foo{split} = (1,1,1,1,1,1,1);
X
XThere's now a range operator that works in array contexts:
X for (1..15) { ...
X @foo[3..5] = ('time','for','all');
X @foo{'Sun','Mon','Tue','Wed','Thu','Fri','Sat'} = 1..7;
X
XYou can now reference associative arrays as a whole:
X %abc = %def;
X %foo = ('Sun',1,'Mon',2,'Tue',3,'Wed',4,'Thu',5,'Fri',6,'Sat',7);
X
XAssociative arrays can now be bound to a dbm or ndbm file. Perl automatically
Xcaches references to the dbm file for you.
X
XAn array or associative array can now be assigned to as part of a list, if
Xit's the last thing in the list:
X ($a,$b, at rest) = split;
X
XAn array or associative array may now appear in a local() list.
X local(%assoc);
X local(@foo) = @_;
X
XArray values may now be interpolated into strings:
X `echo @ARGV`;
X print "first three = @list[0..2]\n";
X print "@ENV{keys(ENV)}";
X ($" is used as the delimiter between array elements)
X
XArray sizes may be interpolated into strings:
X print "The last element is $#foo.\n";
X
XArray values may now be returned from subroutines, evals, and do blocks.
X
XLists of values in formats may now be arbitrary expressions, separated
Xby commas.
X
XSubroutine names are now distinguished by prefixing with &. You can call
Xsubroutines without using do, and without passing any argument list at all:
X $foo = &min($a,$b,$c);
X $num = &myrand;
X
XYou can use the new -u switch to cause perl to dump core so that you can
Xrun undump and produce a binary executable image. Alternately you can
Xuse the "dump" operator after initializing any variables and such.
X
XPerl now optimizes splits that are assigned directly to an array, or
Xto a list with fewer elements than the split would produce, or that
Xsplit on a constant string.
X
XPerl now optimizes on end matches such as /foo$/;
X
XPerl now recognizes {n,m} in patterns to match preceding item at least n times
Xand no more than m times. Also recognizes {n,} and {n} to match n or more
Xtimes, or exactly n times. If { occurs in other than this context it is
Xstill treated as a normal character.
X
XPerl now optimizes "next" to avoid unnecessary longjmps and subroutine calls.
X
XPerl now optimizes appended input: $_ .= <>;
X
XSubstitutions are faster if the substituted text is constant, especially
Xwhen substituting at the beginning of a string. This plus the previous
Xoptimization let you run down a file comparing multiple lines more
Xefficiently. (Basically the equivalents of sed's N and D are faster.)
X
XSimilarly, combinations of shifts and pushes on the same array are much
Xfaster now--it doesn't copy all the pointers every time you shift (just
Xevery n times, where n is approximately the length of the array plus 10,
Xmore if you pre-extend the array), so you can use an array as a shift
Xregister much more efficiently:
X push(@ary,shift(@ary));
Xor
X shift(@ary); push(@ary,<>);
X
XPerl now detects sequences of references to the same variable and builds
Xswitch statements internally wherever reasonable.
X
XThe substr function can take offsets from the end of the string.
X
XThe substr function can be assigned to in order to change the interior of a
Xstring in place.
X
XThe split function can return as part of the returned array any substrings
Xmatched as part of the delimiter:
X split(/([-,])/, '1-10,20')
Xreturns
X (1,'-',10,',',20)
X
XIf you specify a maximum number of fields to split, the truncation of
Xtrailing null fields is disabled.
X
XYou can now chop lists.
X
XPerl now uses /bin/csh to do filename globbing, if available. This means
Xthat filenames with spaces or other strangenesses work right.
X
XPerl can now report multiple syntax errors with a single invocation.
X
XPerl syntax errors now give two tokens of context where reasonable.
X
XPerl will now report the possibility of a runaway multi-line string if
Xsuch a string ends on a line with a syntax error.
X
XThe assumed assignment in a while now works in the while modifier as
Xwell as the while statement.
X
XPerl can now warn you if you use numeric == on non-numeric string values.
X
XNew functions:
X mkdir and rmdir
X getppid
X getpgrp and setpgrp
X getpriority and setpriority
X chroot
X ioctl and fcntl
X flock
X readlink
X lstat
X rindex - find last occurrence of substring
X pack and unpack - turn structures into arrays and vice versa
X read - just what you think
X warn - like die, only not fatal
X dbmopen and dbmclose - bind a dbm file to an associative array
X dump - do core dump so you can undump
X reverse - turns an array value end for end
X defined - does an object exist?
X undef - make an object not exist
X vec - treat string as a vector of small integers
X fileno - return the file descriptor for a handle
X wantarray - was subroutine called in array context?
X gethostbyname
X gethostbyaddr
X gethostent
X sethostent
X endhostent
X getnetbyname
X getnetbyaddr
X getnetent
X setnetent
X endnetent
X getprotobyname
X getprotobynumber
X getprotoent
X setprotoent
X endprotoent
X getservbyname
X getservbyport
X getservent
X setservent
X endservent
X
X
XChanges to s2p
X--------------
X
XIn patterns, s2p now translates \{n,m\} correctly to {n,m}.
X
XIn patterns, s2p no longer removes backslashes in front of |.
X
XIn patterns, s2p now removes backslashes in front of [a-zA-Z0-9].
X
XS2p now makes use of the location of perl as determined by Configure.
X
X
XChanges to a2p
X--------------
X
XA2p can now accurately translate the "in" operator by using perl's new
X"defined" operator.
X
XA2p can now accurately translate the passing of arrays by reference.
X
!STUFFY!FUNK!
echo Extracting regcomp.h
sed >regcomp.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header$
X *
X * $Log$
X */
X
X/*
X * The "internal use only" fields in regexp.h are present to pass info from
X * compile to execute that permits the execute phase to run lots faster on
X * simple cases. They are:
X *
X * regstart str that must begin a match; Nullch if none obvious
X * reganch is the match anchored (at beginning-of-line only)?
X * regmust string (pointer into program) that match must include, or NULL
X * [regmust changed to STR* for bminstr()--law]
X * regmlen length of regmust string
X * [regmlen not used currently]
X *
X * Regstart and reganch permit very fast decisions on suitable starting points
X * for a match, cutting down the work a lot. Regmust permits fast rejection
X * of lines that cannot possibly match. The regmust tests are costly enough
X * that regcomp() supplies a regmust only if the r.e. contains something
X * potentially expensive (at present, the only such thing detected is * or +
X * at the start of the r.e., which can involve a lot of backup). Regmlen is
X * supplied because the test in regexec() needs it and regcomp() is computing
X * it anyway.
X * [regmust is now supplied always. The tests that use regmust have a
X * heuristic that disables the test if it usually matches.]
X *
X * [In fact, we now use regmust in many cases to locate where the search
X * starts in the string, so if regback is >= 0, the regmust search is never
X * wasted effort. The regback variable says how many characters back from
X * where regmust matched is the earliest possible start of the match.
X * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
X */
X
X/*
X * Structure for regexp "program". This is essentially a linear encoding
X * of a nondeterministic finite-state machine (aka syntax charts or
X * "railroad normal form" in parsing technology). Each node is an opcode
X * plus a "next" pointer, possibly plus an operand. "Next" pointers of
X * all nodes except BRANCH implement concatenation; a "next" pointer with
X * a BRANCH on both ends of it is connecting two alternatives. (Here we
X * have one of the subtle syntax dependencies: an individual BRANCH (as
X * opposed to a collection of them) is never concatenated with anything
X * because of operator precedence.) The operand of some types of node is
X * a literal string; for others, it is a node leading into a sub-FSM. In
X * particular, the operand of a BRANCH node is the first node of the branch.
X * (NB this is *not* a tree structure: the tail of the branch connects
X * to the thing following the set of BRANCHes.) The opcodes are:
X */
X
X/* definition number opnd? meaning */
X#define END 0 /* no End of program. */
X#define BOL 1 /* no Match "" at beginning of line. */
X#define EOL 2 /* no Match "" at end of line. */
X#define ANY 3 /* no Match any one character. */
X#define ANYOF 4 /* str Match any character in this string. */
X#define ANYBUT 5 /* str Match any character not in this string. */
X#define BRANCH 6 /* node Match this alternative, or the next... */
X#define BACK 7 /* no Match "", "next" ptr points backward. */
X#define EXACTLY 8 /* str Match this string (preceded by length). */
X#define NOTHING 9 /* no Match empty string. */
X#define STAR 10 /* node Match this (simple) thing 0 or more times. */
X#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
X#define ALNUM 12 /* no Match any alphanumeric character */
X#define NALNUM 13 /* no Match any non-alphanumeric character */
X#define BOUND 14 /* no Match "" at any word boundary */
X#define NBOUND 15 /* no Match "" at any word non-boundary */
X#define SPACE 16 /* no Match any whitespace character */
X#define NSPACE 17 /* no Match any non-whitespace character */
X#define DIGIT 18 /* no Match any numeric character */
X#define NDIGIT 19 /* no Match any non-numeric character */
X#define REF 20 /* no Match some already matched string */
X#define OPEN 30 /* no Mark this point in input as start of #n. */
X /* OPEN+1 is number 1, etc. */
X#define CLOSE 40 /* no Analogous to OPEN. */
X/* CLOSE must be last one! see regmust finder */
X
X/*
X * Opcode notes:
X *
X * BRANCH The set of branches constituting a single choice are hooked
X * together with their "next" pointers, since precedence prevents
X * anything being concatenated to any individual branch. The
X * "next" pointer of the last BRANCH in a choice points to the
X * thing following the whole choice. This is also where the
X * final "next" pointer of each individual branch points; each
X * branch starts with the operand node of a BRANCH node.
X *
X * BACK Normal "next" pointers all implicitly point forward; BACK
X * exists to make loop structures possible.
X *
X * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
X * BRANCH structures using BACK. Simple cases (one character
X * per match) are implemented with STAR and PLUS for speed
X * and to minimize recursive plunges.
X *
X * OPEN,CLOSE ...are numbered at compile time.
X */
X
X/* The following have no fixed length. */
X#ifndef DOINIT
Xextern char varies[];
X#else
Xchar varies[] = {BRANCH,BACK,STAR,PLUS,
X REF+1,REF+2,REF+3,REF+4,REF+5,REF+6,REF+7,REF+8,REF+9,0};
X#endif
X
X/* The following always have a length of 1. */
X#ifndef DOINIT
Xextern char simple[];
X#else
Xchar simple[] = {ANY,ANYOF,ANYBUT,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
X#endif
X
XEXT char regdummy;
X
X/*
X * A node is one char of opcode followed by two chars of "next" pointer.
X * "Next" pointers are stored as two 8-bit pieces, high order first. The
X * value is a positive offset from the opcode of the node containing it.
X * An operand, if any, simply follows the node. (Note that much of the
X * code generation knows about this implicit relationship.)
X *
X * Using two bytes for the "next" pointer is vast overkill for most things,
X * but allows patterns to get big without disasters.
X *
X * [If ALIGN is defined, the "next" pointer is always aligned on an even
X * boundary, and reads the offset directly as a short. Also, there is no
X * special test to reverse the sign of BACK pointers since the offset is
X * stored negative.]
X */
X
X#ifndef gould
X#ifndef cray
X#define REGALIGN
X#endif
X#endif
X
X#define OP(p) (*(p))
X
X#ifndef lint
X#ifdef REGALIGN
X#define NEXT(p) (*(short*)(p+1))
X#else
X#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
X#endif
X#else /* lint */
X#define NEXT(p) 0
X#endif /* lint */
X
X#define OPERAND(p) ((p) + 3)
X
X#ifdef REGALIGN
X#define NEXTOPER(p) ((p) + 4)
X#else
X#define NEXTOPER(p) ((p) + 3)
X#endif
X
X#define MAGIC 0234
X
X/*
X * Utility definitions.
X */
X#ifndef lint
X#ifndef CHARBITS
X#define UCHARAT(p) ((int)*(unsigned char *)(p))
X#else
X#define UCHARAT(p) ((int)*(p)&CHARBITS)
X#endif
X#else /* lint */
X#define UCHARAT(p) regdummy
X#endif /* lint */
X
X#define FAIL(m) fatal("/%s/: %s",regprecomp,m)
X
Xchar *regnext();
X#ifdef DEBUGGING
Xvoid regdump();
Xchar *regprop();
X#endif
X
!STUFFY!FUNK!
echo Extracting x2p/a2p.man
sed >x2p/a2p.man <<'!STUFFY!FUNK!' -e 's/X//'
X.rn '' }`
X''' $Header: a2p.man,v 2.0.1.1 88/07/11 23:16:25 root Exp $
X'''
X''' $Log: a2p.man,v $
X''' Revision 2.0.1.1 88/07/11 23:16:25 root
X''' patch2: changes related to 1985 awk
X'''
X''' Revision 2.0 88/06/05 00:15:36 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 A2P 1 LOCAL
X.SH NAME
Xa2p - Awk to Perl translator
X.SH SYNOPSIS
X.B a2p [options] filename
X.SH DESCRIPTION
X.I A2p
Xtakes an awk script specified on the command line (or from standard input)
Xand produces a comparable
X.I perl
Xscript on the standard output.
X.Sh "Options"
XOptions include:
X.TP 5
X.B \-D<number>
Xsets debugging flags.
X.TP 5
X.B \-F<character>
Xtells a2p that this awk script is always invoked with this -F switch.
X.TP 5
X.B \-n<fieldlist>
Xspecifies the names of the input fields if input does not have to be split into
Xan array.
XIf you were translating an awk script that processes the password file, you
Xmight say:
X.sp
X a2p -7 -nlogin.password.uid.gid.gcos.shell.home
X.sp
XAny delimiter can be used to separate the field names.
X.TP 5
X.B \-<number>
Xcauses a2p to assume that input will always have that many fields.
X.Sh "Considerations"
XA2p cannot do as good a job translating as a human would, but it usually
Xdoes pretty well.
XThere are some areas where you may want to examine the perl script produced
Xand tweak it some.
XHere are some of them, in no particular order.
X.PP
XThere is an awk idiom of putting int() around a string expression to force
Xnumeric interpretation, even though the argument is always integer anyway.
XThis is generally unneeded in perl, but a2p can't tell if the argument
Xis always going to be integer, so it leaves it in.
XYou may wish to remove it.
X.PP
XPerl differentiates numeric comparison from string comparison.
XAwk has one operator for both that decides at run time which comparison
Xto do.
XA2p does not try to do a complete job of awk emulation at this point.
XInstead it guesses which one you want.
XIt's almost always right, but it can be spoofed.
XAll such guesses are marked with the comment \*(L"#???\*(R".
XYou should go through and check them.
XYou might want to run at least once with the \-w switch to perl, which
Xwill warn you if you use == where you should have used eq.
X.PP
XPerl does not attempt to emulate the behavior of awk in which nonexistent
Xarray elements spring into existence simply by being referenced.
XIf somehow you are relying on this mechanism to create null entries for
Xa subsequent for...in, they won't be there in perl.
X.PP
XIf a2p makes a split line that assigns to a list of variables that looks
Xlike (Fld1, Fld2, Fld3...) you may want
Xto rerun a2p using the \-n option mentioned above.
XThis will let you name the fields throughout the script.
XIf it splits to an array instead, the script is probably referring to the number
Xof fields somewhere.
X.PP
XThe exit statement in awk doesn't necessarily exit; it goes to the END
Xblock if there is one.
XAwk scripts that do contortions within the END block to bypass the block under
Xsuch circumstances can be simplified by removing the conditional
Xin the END block and just exiting directly from the perl script.
X.PP
XPerl has two kinds of array, numerically-indexed and associative.
XAwk arrays are usually translated to associative arrays, but if you happen
Xto know that the index is always going to be numeric you could change
Xthe {...} to [...].
XIteration over an associative array is done using the keys() function, but
Xiteration over a numeric array is NOT.
XYou might need to modify any loop that is iterating over the array in question.
X.PP
XAwk starts by assuming OFMT has the value %.6g.
XPerl starts by assuming its equivalent, $#, to have the value %.20g.
XYou'll want to set $# explicitly if you use the default value of OFMT.
X.PP
XNear the top of the line loop will be the split operation that is implicit in
Xthe awk script.
XThere are times when you can move this down past some conditionals that
Xtest the entire record so that the split is not done as often.
X.PP
XFor aesthetic reasons you may wish to change the array base $[ from 1 back
Xto perl's default of 0, but remember to change all array subscripts AND
Xall substr() and index() operations to match.
X.PP
XCute comments that say "# Here is a workaround because awk is dumb" are passed
Xthrough unmodified.
X.PP
XAwk scripts are often embedded in a shell script that pipes stuff into and
Xout of awk.
XOften the shell script wrapper can be incorporated into the perl script, since
Xperl can start up pipes into and out of itself, and can do other things that
Xawk can't do by itself.
X.PP
XScripts that refer to the special variables RSTART and RLENGTH can often
Xbe simplified by referring to the variables $`, $& and $', as long as they
Xare within the scope of the pattern match that sets them.
X.PP
XThe produced perl script may have subroutines defined to deal with awk's
Xsemantics regarding getline and print.
XSince a2p usually picks correctness over efficiency.
Xit is almost always possible to rewrite such code to be more efficient by
Xdiscarding the semantic sugar.
X.PP
XFor efficiency, you may wish to remove the keyword from any return statement
Xthat is the last statement executed in a subroutine.
XA2p catches the most common case, but doesn't analyze embedded blocks for
Xsubtler cases.
X.PP
XARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n].
XA loop that tries to iterate over ARGV[0] won't find it.
X.SH ENVIRONMENT
XA2p uses no environment variables.
X.SH AUTHOR
XLarry Wall <lwall at jpl-devvax.Jpl.Nasa.Gov>
X.SH FILES
X.SH SEE ALSO
Xperl The perl compiler/interpreter
X.br
Xs2p sed to perl translator
X.SH DIAGNOSTICS
X.SH BUGS
XIt would be possible to emulate awk's behavior in selecting string versus
Xnumeric operations at run time by inspection of the operands, but it would
Xbe gross and inefficient.
XBesides, a2p almost always guesses right.
X.PP
XStorage for the awk syntax tree is currently static, and can run out.
X.rn }` ''
!STUFFY!FUNK!
echo Extracting x2p/a2p.h
sed >x2p/a2p.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: a2p.h,v 2.0.1.1 88/07/11 23:14:35 root Exp $
X *
X * Copyright (c) 1989, Larry Wall
X *
X * You may distribute under the terms of the GNU General Public License
X * as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log: a2p.h,v $
X * Revision 2.0.1.1 88/07/11 23:14:35 root
X * patch2: added tokens from 1985 awk
X *
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 OSUBTRACT 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#define ODO 70
X#define OPOW 71
X#define OSUB 72
X#define OGSUB 73
X#define OMATCH 74
X#define OUSERFUN 75
X#define OUSERDEF 76
X#define OCLOSE 77
X#define OATAN2 78
X#define OSIN 79
X#define OCOS 80
X#define ORAND 81
X#define OSRAND 82
X#define ODELETE 83
X#define OSYSTEM 84
X#define OCOND 85
X#define ORETURN 86
X#define ODEFINED 87
X#define OSTAR 88
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 "SUBTRACT",
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 "DO",
X "POW",
X "SUB",
X "GSUB",
X "MATCH",
X "USERFUN",
X "USERDEF",
X "CLOSE",
X "ATAN2",
X "SIN",
X "COS",
X "RAND",
X "SRAND",
X "DELETE",
X "SYSTEM",
X "COND",
X "RETURN",
X "DEFINED",
X "STAR",
X "89"
X};
X#else
Xextern char *opname[];
X#endif
X
XEXT int mop INIT(1);
X
X#define OPSMAX 50000
Xunion {
X int ival;
X char *cval;
X} ops[OPSMAX]; /* hope they have 200k to spare */
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);
XEXT bool saw_altinput 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;
XEXT HASH *curarghash;
X
X#define P_MIN 0
X#define P_LISTOP 5
X#define P_COMMA 10
X#define P_ASSIGN 15
X#define P_COND 20
X#define P_DOTDOT 25
X#define P_OROR 30
X#define P_ANDAND 35
X#define P_OR 40
X#define P_AND 45
X#define P_EQ 50
X#define P_REL 55
X#define P_UNI 60
X#define P_FILETEST 65
X#define P_SHIFT 70
X#define P_ADD 75
X#define P_MUL 80
X#define P_MATCH 85
X#define P_UNARY 90
X#define P_POW 95
X#define P_AUTO 100
X#define P_MAX 999
!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 * 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: 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 t/op.stat
sed >t/op.stat <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.stat,v 2.0.1.1 88/08/03 22:46:11 root Exp $
X
Xprint "1..56\n";
X
Xunlink "Op.stat.tmp";
Xopen(foo, ">Op.stat.tmp");
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X $blksize,$blocks) = stat(foo);
Xif ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";}
Xif ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";}
X
Xprint foo "Now is the time for all good men to come to.\n";
Xclose(foo);
X
X$base = time;
Xwhile (time == $base) {}
X
X`rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X $blksize,$blocks) = stat('Op.stat.tmp');
X
Xif ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";}
Xif ($mtime && $mtime != $ctime) {print "ok 4\n";} else {print "not ok 4\n";}
Xprint "#4 :$mtime: != :$ctime:\n";
X
X`cp /dev/null Op.stat.tmp`;
X
Xif (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
Xif (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";}
X
X`echo hi >Op.stat.tmp`;
Xif (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
Xif (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
X
Xchmod 0,'Op.stat.tmp';
X$olduid = $>; # can't test -r if uid == 0
Xeval '$> = 1;'; # so switch uid (may not be implemented)
Xif (!$> || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
Xif (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
Xeval '$> = $olduid;'; # switch uid back (may not be implemented)
Xif (! -x 'Op.stat.tmp') {print "ok 11\n";} else {print "not ok 11\n";}
X
Xforeach ((12,13,14,15,16,17)) {
X print "ok $_\n"; #deleted tests
X}
X
Xchmod 0700,'Op.stat.tmp';
Xif (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
Xif (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
Xif (-x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";}
X
Xif (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";}
Xif (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";}
X
Xif (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
Xif (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
X
Xif (`ls -l perl` =~ /^l.*->/) {
X if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
X}
Xelse {
X print "ok 25\n";
X}
X
Xif (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
X
Xif (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";}
X`rm -f Op.stat.tmp Op.stat.tmp2`;
Xif (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";}
X
Xif (-c '/dev/tty') {print "ok 29\n";} else {print "not ok 29\n";}
Xif (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
X
Xif (! -e '/dev/printer' || -S '/dev/printer')
X {print "ok 31\n";}
Xelse
X {print "not ok 31\n";}
Xif (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
X
Xif (! -e '/dev/mt0' || -b '/dev/mt0')
X {print "ok 33\n";}
Xelse
X {print "not ok 33\n";}
Xif (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
X
X$cnt = $uid = 0;
X
Xwhile (</usr/bin/*>) {
X $cnt++;
X $uid++ if -u;
X last if $uid && $uid < $cnt;
X}
X
X# I suppose this is going to fail somewhere...
Xif ($uid > 0 && $uid < $cnt) {print "ok 35\n";} else {print "not ok 35\n";}
X
Xunless (open(tty,"/dev/tty")) {
X print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n";
X}
Xif (-t tty) {print "ok 36\n";} else {print "not ok 36\n";}
Xif (-c tty) {print "ok 37\n";} else {print "not ok 37\n";}
Xclose(tty);
Xif (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";}
Xopen(null,"/dev/null");
Xif (! -t null || -e '/xenix') {print "ok 39\n";} else {print "not ok 39\n";}
Xclose(null);
Xif (-t) {print "ok 40\n";} else {print "not ok 40\n";}
X
X# These aren't strictly "stat" calls, but so what?
X
Xif (-T 'op.stat') {print "ok 41\n";} else {print "not ok 41\n";}
Xif (! -B 'op.stat') {print "ok 42\n";} else {print "not ok 42\n";}
X
Xif (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";}
Xif (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";}
X
Xopen(foo,'op.stat');
Xif (-T foo) {print "ok 45\n";} else {print "not ok 45\n";}
Xif (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";}
X$_ = <foo>;
Xif (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
Xif (-T foo) {print "ok 48\n";} else {print "not ok 48\n";}
Xif (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";}
Xclose(foo);
X
Xopen(foo,'op.stat');
X$_ = <foo>;
Xif (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
Xif (-T foo) {print "ok 51\n";} else {print "not ok 51\n";}
Xif (! -B foo) {print "ok 52\n";} else {print "not ok 52\n";}
Xseek(foo,0,0);
Xif (-T foo) {print "ok 53\n";} else {print "not ok 53\n";}
Xif (! -B foo) {print "ok 54\n";} else {print "not ok 54\n";}
Xclose(foo);
X
Xif (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
Xif (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
!STUFFY!FUNK!
echo Extracting munch
sed >munch <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
Xif ($#ARGV < 0) {
X# push(@ARGV,'sgtty.h') if -f '/usr/include/sgtty.h';
X push(@ARGV,'sys/ioctl.h') if -f '/usr/include/sys/ioctl.h';
X}
X
X#system './hdef';
X
Xopen(DB,"hdef.db") || die "Can't open definition database\n";
X$dofile = 1;
Xwhile (<DB>) {
X if ($dofile) {
X chop($filename = $_);
X $dofile = 0;
X next;
X }
X if ($_ eq "\n") {
X $dofile = 1;
X next;
X }
X chop;
X $filename{$_} = $filename unless $filename{$_};
X}
X
Xchop($cwd = `pwd`);
X
Xforeach $file (@ARGV) {
X open(TSORT,"|uniq|tsort >.tsort.out") || die "Can't run tsort\n";
X chdir '/usr/include' || die "Can't cd to /usr/include\n";
X $file =~ s|^/usr/include/||;
X push(@Xinclude, $file);
X $Xinclude{$file} = 1;
X open(FILE,$file) || die "Can't open $file\n";
X while (<FILE>) {
X if (/^#\s*define\s+([A-Z0-9_]+)\s+(.*)/) {
X $sym = $1;
X $def = $2;
X $def =~ s|\s*/\*.*\*/\s*||;
X if ($def =~ /^-?[0-9][0-9a-fA-Fx]*$/) {
X $_ = "\tprintf(\"$file: \$$sym = $def;\\n\", $sym);\n";
X push(@Xlines, $_);
X }
X elsif ($def =~ /^".*"$/) {
X $_ = "\tprintf(\"$file: \$$sym = $def;\\n\", $sym);\n";
X push(@Xlines, $_);
X }
X elsif ($def ne '') {
X $_ = "\tprintf(\"$file: \$$sym = 0x%X;\\n\", $sym);\n";
X push(@Xlines,$_);
X }
X }
X elsif (/^#\s*include\s*<(.+)>/) {
X $Xinclude{$1} = 1; # needn't include twice
X }
X elsif (/^#\s*ifndef\s+(\w+)/) {
X if ($filename{$1} eq $file) {
X $_ = "#ifndef NOTDEF\n";
X push(@Xlines,$_);
X }
X else {
X push(@Xlines,$_);
X }
X }
X elsif (/^#\s*(if|else|endif)/) {
X push(@Xlines,$_);
X }
X }
X
X do include($file);
X chdir $cwd;
X close TSORT;
X open(TSORT,".tsort.out");
X open(FOO,">.foo.c") || die "Can't create .foo.c";
X while (<TSORT>) {
X chop;
X next if $_ eq 'net/if_arp.h' && $Xinclude{'net/if.h'};
X print FOO "#include <$_>\n";
X }
X close TSORT;
X
X print FOO "
X main()
X {\n";
X
X print FOO @Xlines;
X
X print FOO "\texit(0);\n}\n";
X close FOO;
X
X system 'cc', '-o', ".foo", ".foo.c";
X
X die "Can't compile .foo.c" if $?;
X
X system ".foo";
X
X die "Can't execute .foo" if $?;
X
X reset 'X';
X}
X
X#unlink ".foo.c", ".foo";
X
Xsub include {
X local($filename) = @_;
X local($contents,$word,$where);
X unshift(@Xinclude,$filename);
X if (open(INC,$filename)) {
X $/ = "\003";
X $contents = <INC>; # slurp
X $/ = "\n";
X close INC;
X @_ = ();
X $contents =~ s/</-/g;
X $contents =~ s/>/-/g;
X $contents =~ s|/\*|<|g;
X $contents =~ s|\*/|>|g;
X $contents =~ s/<[^>]*>//g;
X $contents =~ s/\\\n//g;
X $contents =~ s/define(.*)/define$1 ENDDEF/g;
X @mywords = split(/\W+/,$contents);
X while ($#mywords >= 0) {
X $word = shift(@mywords);
X if ($word eq 'define') {
X shift(@mywords);
X $defining = 1;
X next;
X }
X if ($word eq 'ENDDEF') {
X $defining = 0;
X next;
X }
X if ($word eq 'struct') {
X $word .= ' ' . shift(@mywords);
X }
X if ($where = $filename{$word}) {
X if ($where ne 'sys/tty.h' || $filename ne 'sys/ioctl.h') {
X if ($defining) {
X print TSORT "$where $where\n";
X }
X else {
X print TSORT "$where $filename\n";
X }
X }
X push(@_,$where) unless $Xinclude{$where}++;
X }
X }
X while ($where = pop(@_)) {
X do include($where);
X }
X }
X else {
X shift(@Xinclude); # not there--back it out
X }
X}
!STUFFY!FUNK!
echo ""
echo "End of kit 19 (of 23)"
cat /dev/null >kit19isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23; 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
More information about the Alt.sources
mailing list