Usenet 1994 October

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

/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part29 < prev next >

Wrap

Internet Message Format | 1991-04-17 | 49.3 KB

From: lwall@netlabs.com (Larry Wall) Newsgroups: comp.sources.misc Subject: v18i047: perl - The perl programming language, Part29/36 Message-ID: <1991Apr17.185818.2774@sparky.IMD.Sterling.COM> Date: 17 Apr 91 18:58:18 GMT Approved: kent@sparky.imd.sterling.com X-Checksum-Snefru: bc6fd766 0f632609 54a59b7b 75394100 Submitted-by: Larry Wall <lwall@netlabs.com> Posting-number: Volume 18, Issue 47 Archive-name: perl/part29 [There are 36 kits for perl version 4.0.] #! /bin/sh # Make a new directory for the perl sources, cd to it, and run kits 1 # thru 36 through sh. When all 36 kits have been run, read README. echo "This is perl 4.0 kit 29 (of 36). If kit 29 is complete, the line" echo '"'"End of kit 29 (of 36)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir lib os2 x2p 2>/dev/null echo Extracting dump.c sed >dump.c <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: dump.c,v 4.0 91/03/20 01:08:25 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: dump.c,v $ X * Revision 4.0 91/03/20 01:08:25 lwall X * 4.0 baseline. X * X */ X X#include "EXTERN.h" X#include "perl.h" X X#ifdef DEBUGGING Xstatic int dumplvl = 0; X Xdump_all() X{ X register int i; X register STAB *stab; X register HENT *entry; X STR *str = str_mortal(&str_undef); X X dump_cmd(main_root,Nullcmd); X for (i = 0; i <= 127; i++) { X for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) { X stab = (STAB*)entry->hent_val; X if (stab_sub(stab)) { X stab_fullname(str,stab); X dump("\nSUB %s = ", str->str_ptr); X dump_cmd(stab_sub(stab)->cmd,Nullcmd); X } X } X } X} X Xdump_cmd(cmd,alt) Xregister CMD *cmd; Xregister CMD *alt; X{ X fprintf(stderr,"{\n"); X while (cmd) { X dumplvl++; X dump("C_TYPE = %s\n",cmdname[cmd->c_type]); X dump("C_ADDR = 0x%lx\n",cmd); X dump("C_NEXT = 0x%lx\n",cmd->c_next); X if (cmd->c_line) X dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd); X if (cmd->c_label) X dump("C_LABEL = \"%s\"\n",cmd->c_label); X dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]); X *buf = '\0'; X if (cmd->c_flags & CF_FIRSTNEG) X (void)strcat(buf,"FIRSTNEG,"); X if (cmd->c_flags & CF_NESURE) X (void)strcat(buf,"NESURE,"); X if (cmd->c_flags & CF_EQSURE) X (void)strcat(buf,"EQSURE,"); X if (cmd->c_flags & CF_COND) X (void)strcat(buf,"COND,"); X if (cmd->c_flags & CF_LOOP) X (void)strcat(buf,"LOOP,"); X if (cmd->c_flags & CF_INVERT) X (void)strcat(buf,"INVERT,"); X if (cmd->c_flags & CF_ONCE) X (void)strcat(buf,"ONCE,"); X if (cmd->c_flags & CF_FLIP) X (void)strcat(buf,"FLIP,"); X if (cmd->c_flags & CF_TERM) X (void)strcat(buf,"TERM,"); X if (*buf) X buf[strlen(buf)-1] = '\0'; X dump("C_FLAGS = (%s)\n",buf); X if (cmd->c_short) { X dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short)); X dump("C_SLEN = \"%d\"\n",cmd->c_slen); X } X if (cmd->c_stab) { X dump("C_STAB = "); X dump_stab(cmd->c_stab); X } X if (cmd->c_spat) { X dump("C_SPAT = "); X dump_spat(cmd->c_spat); X } X if (cmd->c_expr) { X dump("C_EXPR = "); X dump_arg(cmd->c_expr); X } else X dump("C_EXPR = NULL\n"); X switch (cmd->c_type) { X case C_NEXT: X case C_WHILE: X case C_BLOCK: X case C_ELSE: X case C_IF: X if (cmd->ucmd.ccmd.cc_true) { X dump("CC_TRUE = "); X dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt); X } X else X dump("CC_TRUE = NULL\n"); X if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) { X dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); X } X else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) { X dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); X } X else X dump("CC_ALT = NULL\n"); X break; X case C_EXPR: X if (cmd->ucmd.acmd.ac_stab) { X dump("AC_STAB = "); X dump_stab(cmd->ucmd.acmd.ac_stab); X } else X dump("AC_STAB = NULL\n"); X if (cmd->ucmd.acmd.ac_expr) { X dump("AC_EXPR = "); X dump_arg(cmd->ucmd.acmd.ac_expr); X } else X dump("AC_EXPR = NULL\n"); X break; X case C_CSWITCH: X case C_NSWITCH: X { X int max, i; X X max = cmd->ucmd.scmd.sc_max; X dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1); X dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1); X dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]); X for (i = 1; i < max; i++) X dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset, X cmd->ucmd.scmd.sc_next[i]); X dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]); X } X break; X } X cmd = cmd->c_next; X if (cmd && cmd->c_head == cmd) { /* reached end of while loop */ X dump("C_NEXT = HEAD\n"); X dumplvl--; X dump("}\n"); X break; X } X dumplvl--; X dump("}\n"); X if (cmd) X if (cmd == alt) X dump("CONT 0x%lx {\n",cmd); X else X dump("{\n"); X } X} X Xdump_arg(arg) Xregister ARG *arg; X{ X register int i; X X fprintf(stderr,"{\n"); X dumplvl++; X dump("OP_TYPE = %s\n",opname[arg->arg_type]); X dump("OP_LEN = %d\n",arg->arg_len); X if (arg->arg_flags) { X dump_flags(buf,arg->arg_flags); X dump("OP_FLAGS = (%s)\n",buf); X } X for (i = 1; i <= arg->arg_len; i++) { X dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK], X arg[i].arg_type & A_DONT ? " (unevaluated)" : ""); X if (arg[i].arg_len) X dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len); X if (arg[i].arg_flags) { X dump_flags(buf,arg[i].arg_flags); X dump("[%d]ARG_FLAGS = (%s)\n",i,buf); X } X switch (arg[i].arg_type & A_MASK) { X case A_NULL: X if (arg->arg_type == O_TRANS) { X short *tbl = (short*)arg[2].arg_ptr.arg_cval; X int i; X X for (i = 0; i < 256; i++) { X if (tbl[i] >= 0) X dump(" %d -> %d\n", i, tbl[i]); X else if (tbl[i] == -2) X dump(" %d -> DELETE\n", i); X } X } X break; X case A_LEXPR: X case A_EXPR: X dump("[%d]ARG_ARG = ",i); X dump_arg(arg[i].arg_ptr.arg_arg); X break; X case A_CMD: X dump("[%d]ARG_CMD = ",i); X dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd); X break; X case A_WORD: X case A_STAB: X case A_LVAL: X case A_READ: X case A_GLOB: X case A_ARYLEN: X case A_ARYSTAB: X case A_LARYSTAB: X dump("[%d]ARG_STAB = ",i); X dump_stab(arg[i].arg_ptr.arg_stab); X break; X case A_SINGLE: X case A_DOUBLE: X case A_BACKTICK: X dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str)); X break; X case A_SPAT: X dump("[%d]ARG_SPAT = ",i); X dump_spat(arg[i].arg_ptr.arg_spat); X break; X } X } X dumplvl--; X dump("}\n"); X} X Xdump_flags(b,flags) Xchar *b; Xunsigned int flags; X{ X *b = '\0'; X if (flags & AF_ARYOK) X (void)strcat(b,"ARYOK,"); X if (flags & AF_POST) X (void)strcat(b,"POST,"); X if (flags & AF_PRE) X (void)strcat(b,"PRE,"); X if (flags & AF_UP) X (void)strcat(b,"UP,"); X if (flags & AF_COMMON) X (void)strcat(b,"COMMON,"); X if (flags & AF_DEPR) X (void)strcat(b,"DEPR,"); X if (flags & AF_LISTISH) X (void)strcat(b,"LISTISH,"); X if (flags & AF_LOCAL) X (void)strcat(b,"LOCAL,"); X if (*b) X b[strlen(b)-1] = '\0'; X} X Xdump_stab(stab) Xregister STAB *stab; X{ X STR *str; X X if (!stab) { X fprintf(stderr,"{}\n"); X return; X } X str = str_mortal(&str_undef); X dumplvl++; X fprintf(stderr,"{\n"); X stab_fullname(str,stab); X dump("STAB_NAME = %s\n", str->str_ptr); X dumplvl--; X dump("}\n"); X} X Xdump_spat(spat) Xregister SPAT *spat; X{ X char ch; X X if (!spat) { X fprintf(stderr,"{}\n"); X return; X } X fprintf(stderr,"{\n"); X dumplvl++; X if (spat->spat_runtime) { X dump("SPAT_RUNTIME = "); X dump_arg(spat->spat_runtime); X } else { X if (spat->spat_flags & SPAT_ONCE) X ch = '?'; X else X ch = '/'; X dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch); X } X if (spat->spat_repl) { X dump("SPAT_REPL = "); X dump_arg(spat->spat_repl); X } X if (spat->spat_short) { X dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short)); X } X dumplvl--; X dump("}\n"); X} X X/* VARARGS1 */ Xdump(arg1,arg2,arg3,arg4,arg5) Xchar *arg1; Xlong arg2, arg3, arg4, arg5; X{ X int i; X X for (i = dumplvl*4; i; i--) X (void)putc(' ',stderr); X fprintf(stderr,arg1, arg2, arg3, arg4, arg5); X} X#endif X X#ifdef DEBUG Xchar * Xshowinput() X{ X register char *s = str_get(linestr); X int fd; X static char cmd[] = X {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040, X 074,057,024,015,020,057,056,006,017,017,0}; X X if (rsfp != stdin || strnEQ(s,"#!",2)) X return s; X for (; *s; s++) { X if (*s & 0200) { X fd = creat("/tmp/.foo",0600); X write(fd,str_get(linestr),linestr->str_cur); X while(s = str_gets(linestr,rsfp,0)) { X write(fd,s,linestr->str_cur); X } X (void)close(fd); X for (s=cmd; *s; s++) X if (*s < ' ') X *s += 96; X rsfp = mypopen(cmd,"r"); X s = str_gets(linestr,rsfp,0); X return s; X } X } X return str_get(linestr); X} X#endif !STUFFY!FUNK! echo Extracting lib/bigint.pl sed >lib/bigint.pl <<'!STUFFY!FUNK!' -e 's/X//' Xpackage bigint; X X# arbitrary size integer math package X# X# by Mark Biggar X# X# Canonical Big integer value are strings of the form X# /^[+-]\d+$/ with leading zeros suppressed X# Input values to these routines may be strings of the form X# /^\s*[+-]?[\d\s]+$/. X# Examples: X# '+0' canonical zero value X# ' -123 123 123' canonical value '-123123123' X# '1 23 456 7890' canonical value '+1234567890' X# Output values always always in canonical form X# X# Actual math is done in an internal format consisting of an array X# whose first element is the sign (/^[+-]$/) and whose remaining X# elements are base 100000 digits with the least significant digit first. X# The string 'NaN' is used to represent the result when input arguments X# are not numbers, as well as the result of dividing by zero X# X# routines provided are: X# X# bneg(BINT) return BINT negation X# babs(BINT) return BINT absolute value X# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) X# badd(BINT,BINT) return BINT addition X# bsub(BINT,BINT) return BINT subtraction X# bmul(BINT,BINT) return BINT multiplication X# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar X# bmod(BINT,BINT) return BINT modulus X# bgcd(BINT,BINT) return BINT greatest common divisor X# bnorm(BINT) return BINT normalization X# X X# normalize string form of number. Strip leading zeros. Strip any X# white space and add a sign, if missing. X# Strings that are not numbers result the value 'NaN'. Xsub main'bnorm { #(num_str) return num_str X local($_) = @_; X s/\s+//g; # strip white space X if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number X substr($_,0,0) = '+' unless $1; # Add missing sign X s/^-0/+0/; X $_; X } else { X 'NaN'; X } X} X X# Convert a number from string format to internal base 100000 format. X# Assumes normalized value as input. Xsub internal { #(num_str) return int_num_array X local($d) = @_; X ($is,$il) = (substr($d,0,1),length($d)-2); X substr($d,0,1) = ''; X ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); X} X X# Convert a number from internal base 100000 format to string format. X# This routine scribbles all over input array. Xsub external { #(int_num_array) return num_str X $es = shift; X grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad X &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize X} X X# Negate input value. Xsub main'bneg { #(num_str) return num_str X local($_) = &'bnorm(@_); X vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; X s/^H/N/; X $_; X} X X# Returns the absolute value of the input. Xsub main'babs { #(num_str) return num_str X &abs(&'bnorm(@_)); X} X Xsub abs { # post-normalized abs for internal use X local($_) = @_; X s/^-/+/; X $_; X} X X# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) Xsub main'bcmp { #(num_str, num_str) return cond_code X local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); X if ($x eq 'NaN') { X undef; X } elsif ($y eq 'NaN') { X undef; X } else { X &cmp($x,$y); X } X} X Xsub cmp { # post-normalized compare for internal use X local($cx, $cy) = @_; X $cx cmp $cy X && X ( X ord($cy) <=> ord($cx) X || X ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) X ); X} X Xsub main'badd { #(num_str, num_str) return num_str X local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1])); X if ($x eq 'NaN') { X 'NaN'; X } elsif ($y eq 'NaN') { X 'NaN'; X } else { X @x = &internal($x); # convert to internal form X @y = &internal($y); X local($sx, $sy) = (shift @x, shift @y); # get signs X if ($sx eq $sy) { X &external($sx, &add(*x, *y)); # if same sign add X } else { X ($x, $y) = (&abs($x),&abs($y)); # make abs X if (&cmp($y,$x) > 0) { X &external($sy, &sub(*y, *x)); X } else { X &external($sx, &sub(*x, *y)); X } X } X } X} X Xsub main'bsub { #(num_str, num_str) return num_str X &'badd($_[0],&'bneg($_[1])); X} X X# GCD -- Euclids algorithm Knuth Vol 2 pg 296 Xsub main'bgcd { #(num_str, num_str) return num_str X local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); X if ($x eq 'NaN') { X 'NaN'; X } X elsif ($y eq 'NaN') { X 'NaN'; X } X else { X ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; X $x; X } X} X X# routine to add two base 100000 numbers X# stolen from Knuth Vol 2 Algorithm A pg 231 X# there are separate routines to add and sub as per Kunth pg 233 Xsub add { #(int_num_array, int_num_array) return int_num_array X local(*x, *y) = @_; X $car = 0; X for $x (@x) { X last unless @y || $car; X $x -= 100000 if $car = (($x += shift @y + $car) >= 100000); X } X for $y (@y) { X last unless $car; X $y -= 100000 if $car = (($y += $car) >= 100000); X } X (@x, @y, $car); X} X X# subtract base 100000 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y Xsub sub { #(int_num_array, int_num_array) return int_num_array X local(*sx, *sy) = @_; X $bar = 0; X for $sx (@sx) { X last unless @y || $bar; X $sx += 100000 if $bar = (($sx -= shift @sy + $bar) < 0); X } X @sx; X} X X# multiply two numbers -- stolen from Knuth Vol 2 pg 233 Xsub main'bmul { #(num_str, num_str) return num_str X local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); X if ($x eq 'NaN') { X 'NaN'; X } elsif ($y eq 'NaN') { X 'NaN'; X } else { X @x = &internal($x); X @y = &internal($y); X local($signr) = (shift @x ne shift @y) ? '-' : '+'; X @prod = (); X for $x (@x) { X ($car, $cty) = (0, 0); X for $y (@y) { X $prod = $x * $y + $prod[$cty] + $car; X $prod[$cty++] = X $prod - ($car = int($prod * (1/100000))) * 100000; X } X $prod[$cty] += $car if $car; X $x = shift @prod; X } X &external($signr, @x, @prod); X } X} X X# modulus Xsub main'bmod { #(num_str, num_str) return num_str X (&'bdiv(@_))[1]; X} X Xsub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str X local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); X return wantarray ? ('NaN','NaN') : 'NaN' X if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); X return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); X @x = &internal($x); @y = &internal($y); X $srem = $y[0]; X $sr = (shift @x ne shift @y) ? '-' : '+'; X $car = $bar = $prd = 0; X if (($dd = int(100000/($y[$#y]+1))) != 1) { X for $x (@x) { X $x = $x * $dd + $car; X $x -= ($car = int($x * (1/100000))) * 100000; X } X push(@x, $car); $car = 0; X for $y (@y) { X $y = $y * $dd + $car; X $y -= ($car = int($y * (1/100000))) * 100000; X } X } X else { X push(@x, 0); X } X @q = (); ($v2,$v1) = @y[$#y-1,$#y]; X while ($#x > $#y) { X ($u2,$u1,$u0) = @x[($#x-2)..$#x]; X $q = (($u0 == $v1) ? 99999 : int(($u0*100000+$u1)/$v1)); X --$q while ($v2*$q > ($u0*100000+$u1-$q*$v1)*100000+$u2); X if ($q) { X ($car, $bar) = (0,0); X for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { X $prd = $q * $y[$y] + $car; X $prd -= ($car = int($prd * (1/100000))) * 100000; X $x[$x] += 100000 if ($bar = (($x[$x] -= $prd + $bar) < 0)); X } X if ($x[$#x] < $car + $bar) { X $car = 0; --$q; X for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { X $x[$x] -= 100000 X if ($car = (($x[$x] += $y[$y] + $car) > 100000)); X } X } X } X pop(@x); unshift(@q, $q); X } X if (wantarray) { X @d = (); X if ($dd != 1) { X $car = 0; X for $x (reverse @x) { X $prd = $car * 100000 + $x; X $car = $prd - ($tmp = int($prd / $dd)) * $dd; X unshift(@d, $tmp); X } X } X else { X @d = @x; X } X (&external($sr, @q), &external($srem, @d, 0)); X } else { X &external($sr, @q); X } X} X1; !STUFFY!FUNK! echo Extracting regcomp.h sed >regcomp.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $ X * X * $Log: regcomp.h,v $ X * Revision 4.0 91/03/20 01:39:09 lwall X * 4.0 baseline. X * 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 character in (or not in) this class. */ X#define CURLY 5 /* str Match this simple thing {n,m} times. */ 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 /* num Match some already matched string */ X#define OPEN 21 /* num Mark this point in input as start of #n. */ X#define CLOSE 22 /* num Analogous to OPEN. */ 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#ifndef DOINIT Xextern char regarglen[]; X#else Xchar regarglen[] = {0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2}; X#endif X X/* The following have no fixed length. */ X#ifndef DOINIT Xextern char varies[]; X#else Xchar varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,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,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 REGALIGN 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#ifndef eta10 X#define REGALIGN X#endif 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#define ARG1(p) (*(unsigned short*)(p+3)) X#define ARG2(p) (*(unsigned short*)(p+5)) X#else X#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) X#define ARG1(p) (((*((p)+3)&0377)<<8) + (*((p)+4)&0377)) X#define ARG2(p) (((*((p)+5)&0377)<<8) + (*((p)+6)&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 lib/bigfloat.pl sed >lib/bigfloat.pl <<'!STUFFY!FUNK!' -e 's/X//' Xpackage bigfloat; Xrequire "bigint.pl"; X X# Arbitrary length float math package X# X# number format X# canonical strings have the form /[+-]\d+E[+-]\d+/ X# Input values can have inbedded whitespace X# Error returns X# 'NaN' An input parameter was "Not a Number" or X# divide by zero or sqrt of negative number X# Division is computed to X# max($div_scale,length(dividend).length(divisor)) X# digits by default. X# Also used for default sqrt scale X X$div_scale = 40; X X# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. X X$rnd_mode = 'even'; X X# bigfloat routines X# X# fadd(NSTR, NSTR) return NSTR addition X# fsub(NSTR, NSTR) return NSTR subtraction X# fmul(NSTR, NSTR) return NSTR multiplication X# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places X# fneg(NSTR) return NSTR negation X# fabs(NSTR) return NSTR absolute value X# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 X# fround(NSTR, SCALE) return NSTR round to SCALE digits X# ffround(NSTR, SCALE) return NSTR round at SCALEth place X# fnorm(NSTR) return (NSTR) normalize X# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places X X# Convert a number to canonical string form. X# Takes something that looks like a number and converts it to X# the form /^[+-]\d+E[+-]\d+$/. Xsub main'fnorm { #(string) return fnum_str X local($_) = @_; X s/\s+//g; # strip white space X if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { X &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); X } else { X 'NaN'; X } X} X X# normalize number -- for internal use Xsub norm { #(mantissa, exponent) return fnum_str X local($_, $exp) = @_; X if ($_ eq 'NaN') { X 'NaN'; X } else { X s/^([+-])0+/$1/; # strip leading zeros X if (length($_) == 1) { X '+0E+0'; X } else { X $exp += length($1) if (s/(0+)$//); # strip trailing zeros X sprintf("%sE%+ld", $_, $exp); X } X } X} X X# negation Xsub main'fneg { #(fnum_str) return fnum_str X local($_) = &'fnorm($_[0]); X substr($_,0,1) =~ tr/+-/-+/ if ($_ ne '+0E+0'); # flip sign X $_; X} X X# absolute value Xsub main'fabs { #(fnum_str) return fnum_str X local($_) = &'fnorm($_[0]); X substr($_,0,1) = '+' unless $_ eq 'NaN'; # mash sign X $_; X} X X# multiplication Xsub main'fmul { #(fnum_str, fnum_str) return fnum_str X local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); X if ($x eq 'NaN' || $y eq 'NaN') { X 'NaN'; X } else { X local($xm,$xe) = split('E',$x); X local($ym,$ye) = split('E',$y); X &norm(&'bmul($xm,$ym),$xe+$ye); X } X} X X# addition Xsub main'fadd { #(fnum_str, fnum_str) return fnum_str X local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); X if ($x eq 'NaN' || $y eq 'NaN') { X 'NaN'; X } else { X local($xm,$xe) = split('E',$x); X local($ym,$ye) = split('E',$y); X ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); X &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye); X } X} X X# subtraction Xsub main'fsub { #(fnum_str, fnum_str) return fnum_str X &'fadd($_[0],&'fneg($_[1])); X} X X# division X# args are dividend, divisor, scale (optional) X# result has at most max(scale, length(dividend), length(divisor)) digits Xsub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str X{ X local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]); X if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { X 'NaN'; X } else { X local($xm,$xe) = split('E',$x); X local($ym,$ye) = split('E',$y); X $scale = $div_scale if (!$scale); X $scale = length($xm)-1 if (length($xm)-1 > $scale); X $scale = length($ym)-1 if (length($ym)-1 > $scale); X $scale = $scale + length($ym) - length($xm); X &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym), X $xe-$ye-$scale); X } X} X X# round int $q based on fraction $r/$base using $rnd_mode Xsub round { #(int_str, int_str, int_str) return int_str X local($q,$r,$base) = @_; X if ($q eq 'NaN' || $r eq 'NaN') { X 'NaN'; X } elsif ($rnd_mode eq 'trunc') { X $q; # just truncate X } else { X local($cmp) = &'bcmp(&'bmul($r,'+2'),$base); X if ( $cmp < 0 || X ($cmp == 0 && X ( $rnd_mode eq 'zero' || X ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) || X ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) || X ($rnd_mode eq 'even' && $q =~ /[24680]$/) || X ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { X $q; # round down X } else { X &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1')); X # round up X } X } X} X X# round the mantissa of $x to $scale digits Xsub main'fround { #(fnum_str, scale) return fnum_str X local($x,$scale) = (&'fnorm($_[0]),$_[1]); X if ($x eq 'NaN' || $scale <= 0) { X $x; X } else { X local($xm,$xe) = split('E',$x); X if (length($xm)-1 <= $scale) { X $x; X } else { X &norm(&round(substr($xm,0,$scale+1), X "+0".substr($xm,$scale+1,1),"+10"), X $xe+length($xm)-$scale-1); X } X } X} X X# round $x at the 10 to the $scale digit place Xsub main'ffround { #(fnum_str, scale) return fnum_str X local($x,$scale) = (&'fnorm($_[0]),$_[1]); X if ($x eq 'NaN') { X 'NaN'; X } else { X local($xm,$xe) = split('E',$x); X if ($xe >= $scale) { X $x; X } else { X $xe = length($xm)+$xe-$scale; X if ($xe < 1) { X '+0E+0'; X } elsif ($xe == 1) { X &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale); X } else { X &norm(&round(substr($xm,0,$trunc), X "+0".substr($xm,$trunc,1),"+10"), $scale); X } X } X } X} X X# compare 2 values returns one of undef, <0, =0, >0 X# returns undef if either or both input value are not numbers Xsub main'fcmp #(fnum_str, fnum_str) return cond_code X{ X local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1])); X if ($x eq "NaN" || $y eq "NaN") { X undef; X } elsif ($x eq $y) { X 0; X } elsif (ord($x) != ord($y)) { X (ord($y) - ord($x)); # based on signs X } else { X local($xm,$xe) = split('E',$x); X local($ym,$ye) = split('E',$y); X if ($xe ne $ye) { X ($xe - $ye) * (substr($x,0,1).'1'); X } else { X &bigint'cmp($xm,$ym); # based on value X } X } X} X X# square root by Newtons method. Xsub main'fsqrt { #(fnum_str[, scale]) return fnum_str X local($x, $scale) = (&'fnorm($_[0]), $_[1]); X if ($x eq 'NaN' || $x =~ /^-/) { X 'NaN'; X } elsif ($x eq '+0E+0') { X '+0E+0'; X } else { X local($xm, $xe) = split('E',$x); X $scale = $div_scale if (!$scale); X $scale = length($xm)-1 if ($scale < length($xm)-1); X local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); X while ($gs < 2*$scale) { X $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5"); X $gs *= 2; X } X &'fround($guess, $scale); X } X} X X1; !STUFFY!FUNK! echo Extracting x2p/a2p.man sed >x2p/a2p.man <<'!STUFFY!FUNK!' -e 's/X//' X.rn '' }` X''' $Header: a2p.man,v 4.0 91/03/20 01:57:11 lwall Locked $ X''' X''' $Log: a2p.man,v $ X''' Revision 4.0 91/03/20 01:57:11 lwall X''' 4.0 baseline. X''' X''' Revision 3.0 89/10/18 15:34:22 lwall X''' 3.0 baseline X''' 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@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 4.0 91/03/20 01:57:07 lwall Locked $ X * X * Copyright (c) 1989, Larry Wall X * X * You may distribute under the terms of the GNU General Public License X * as specified in the README file that comes with the perl 3.0 kit. X * X * $Log: a2p.h,v $ X * Revision 4.0 91/03/20 01:57:07 lwall X * 4.0 baseline. X * X */ X X#define VOIDUSED 1 X#include "../config.h" X X#ifndef HAS_BCOPY X# define bcopy(s1,s2,l) memcpy(s2,s1,l) X#endif X#ifndef HAS_BZERO 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 Xunion u_ops { X int ival; X char *cval; X}; X#if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */ X#define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */ X#else X#define OPSMAX 50000 X#endif /* 80286 hack */ Xunion u_ops ops[OPSMAX]; 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[2048]; XEXT char *bufptr INIT(buf); X XEXT STR *linestr INIT(Nullstr); X XEXT char tokenbuf[2048]; 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 os2/suffix.c sed >os2/suffix.c <<'!STUFFY!FUNK!' -e 's/X//' X/* X * Suffix appending for in-place editing under MS-DOS and OS/2. X * X * Here are the rules: X * X * Style 0: Append the suffix exactly as standard perl would do it. X * If the filesystem groks it, use it. (HPFS will always X * grok it. FAT will rarely accept it.) X * X * Style 1: The suffix begins with a '.'. The extension is replaced. X * If the name matches the original name, use the fallback method. X * X * Style 2: The suffix is a single character, not a '.'. Try to add the X * suffix to the following places, using the first one that works. X * [1] Append to extension. X * [2] Append to filename, X * [3] Replace end of extension, X * [4] Replace end of filename. X * If the name matches the original name, use the fallback method. X * X * Style 3: Any other case: Ignore the suffix completely and use the X * fallback method. X * X * Fallback method: Change the extension to ".$$$". If that matches the X * original name, then change the extension to ".~~~". X * X * If filename is more than 1000 characters long, we die a horrible X * death. Sorry. X * X * The filename restriction is a cheat so that we can use buf[] to store X * assorted temporary goo. X * X * Examples, assuming style 0 failed. X * X * suffix = ".bak" (style 1) X * foo.bar => foo.bak X * foo.bak => foo.$$$ (fallback) X * foo.$$$ => foo.~~~ (fallback) X * makefile => makefile.bak X * X * suffix = "~" (style 2) X * foo.c => foo.c~ X * foo.c~ => foo.c~~ X * foo.c~~ => foo~.c~~ X * foo~.c~~ => foo~~.c~~ X * foo~~~~~.c~~ => foo~~~~~.$$$ (fallback) X * X * foo.pas => foo~.pas X * makefile => makefile.~ X * longname.fil => longname.fi~ X * longname.fi~ => longnam~.fi~ X * longnam~.fi~ => longnam~.$$$ X * X */ X X#include "EXTERN.h" X#include "perl.h" X#ifdef OS2 X#define INCL_DOSFILEMGR X#define INCL_DOSERRORS X#include <os2.h> X#endif /* OS2 */ X Xstatic char suffix1[] = ".$$$"; Xstatic char suffix2[] = ".~~~"; X X#define ext (&buf[1000]) X Xadd_suffix(str,suffix) Xregister STR *str; Xregister char *suffix; X{ X int baselen; X int extlen; X char *s, *t, *p; X STRLEN slen; X X if (!(str->str_pok)) (void)str_2ptr(str); X if (str->str_cur > 1000) X fatal("Cannot do inplace edit on long filename (%d characters)", str->str_cur); X X#ifdef OS2 X /* Style 0 */ X slen = str->str_cur; X str_cat(str, suffix); X if (valid_filename(str->str_ptr)) return; X X /* Fooey, style 0 failed. Fix str before continuing. */ X str->str_ptr[str->str_cur = slen] = '\0'; X#endif /* OS2 */ X X slen = strlen(suffix); X t = buf; baselen = 0; s = str->str_ptr; X while ( (*t = *s) && *s != '.') { X baselen++; X if (*s == '\\' || *s == '/') baselen = 0; X s++; t++; X } X p = t; X X t = ext; extlen = 0; X while (*t++ = *s++) extlen++; X if (extlen == 0) { ext[0] = '.'; ext[1] = 0; extlen++; } X X if (*suffix == '.') { /* Style 1 */ X if (strEQ(ext, suffix)) goto fallback; X strcpy(p, suffix); X } else if (suffix[1] == '\0') { /* Style 2 */ X if (extlen < 4) { X ext[extlen] = *suffix; X ext[++extlen] = '\0'; X } else if (baselen < 8) { X *p++ = *suffix; X } else if (ext[3] != *suffix) { X ext[3] = *suffix; X } else if (buf[7] != *suffix) { X buf[7] = *suffix; X } else goto fallback; X strcpy(p, ext); X } else { /* Style 3: Panic */ Xfallback: X (void)bcopy(strEQ(ext, suffix1) ? suffix2 : suffix1, p, 4+1); X } X str_set(str, buf); X} X X#ifdef OS2 Xint Xvalid_filename(s) Xchar *s; X{ X HFILE hf; X USHORT usAction; X X switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN, X OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) { X case ERROR_INVALID_NAME: X case ERROR_FILENAME_EXCED_RANGE: X return 0; X case NO_ERROR: X DosClose(hf); X /*FALLTHROUGH*/ X default: X return 1; X } X} X#endif /* OS2 */ !STUFFY!FUNK! echo " " echo "End of kit 29 (of 36)" cat /dev/null >kit29isdone run='' config='' for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do if test -f kit${iskit}isdone; then run="$run $iskit" else todo="$todo $iskit" fi done case $todo in '') echo "You have run all your kits. Please read README and then type Configure." for combo in *:AA; do if test -f "$combo"; then realfile=`basename $combo :AA` cat $realfile:[A-Z][A-Z] >$realfile rm -rf $realfile:[A-Z][A-Z] fi done rm -rf kit*isdone chmod 755 Configure ;; *) echo "You have run$run." echo "You still need to run$todo." ;; esac : Someone might mail this, so... exit exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.