lwall@netlabs.com (Larry Wall) (04/18/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 44
Archive-name: perl/part26
[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 26 (of 36). If kit 26 is complete, the line"
echo '"'"End of kit 26 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg lib x2p 2>/dev/null
echo Extracting lib/perldb.pl
sed >lib/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xpackage DB;
X
X$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
X#
X# This file is automatically included if you do perl -d.
X# It's probably not useful to include this yourself.
X#
X# Perl supplies the values for @line and %sub. It effectively inserts
X# a do DB'DB(<linenum>); in front of every place that can
X# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
X#
X# $Log: perldb.pl,v $
X# Revision 4.0 91/03/20 01:25:50 lwall
X# 4.0 baseline.
X#
X# Revision 3.0.1.6 91/01/11 18:08:58 lwall
X# patch42: @_ couldn't be accessed from debugger
X#
X# Revision 3.0.1.5 90/11/10 01:40:26 lwall
X# patch38: the debugger wouldn't stop correctly or do action routines
X#
X# Revision 3.0.1.4 90/10/15 17:40:38 lwall
X# patch29: added caller
X# patch29: the debugger now understands packages and evals
X# patch29: scripts now run at almost full speed under the debugger
X# patch29: more variables are settable from debugger
X#
X# Revision 3.0.1.3 90/08/09 04:00:58 lwall
X# patch19: debugger now allows continuation lines
X# patch19: debugger can now dump lists of variables
X# patch19: debugger can now add aliases easily from prompt
X#
X# Revision 3.0.1.2 90/03/12 16:39:39 lwall
X# patch13: perl -d didn't format stack traces of *foo right
X# patch13: perl -d wiped out scalar return values of subroutines
X#
X# Revision 3.0.1.1 89/10/26 23:14:02 lwall
X# patch1: RCS expanded an unintended $Header in lib/perldb.pl
X#
X# Revision 3.0 89/10/18 15:19:46 lwall
X# 3.0 baseline
X#
X# Revision 2.0 88/06/05 00:09:45 root
X# Baseline version 2.0.
X#
X#
X
Xopen(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
Xopen(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
Xselect(OUT);
X$| = 1; # for DB'OUT
Xselect(STDOUT);
X$| = 1; # for real STDOUT
X$sub = '';
X
X$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
Xprint OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
X
Xsub DB {
X &save;
X ($package, $filename, $line) = caller;
X $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
X "package $package;"; # this won't let them modify, alas
X local(*dbline) = "_<$filename";
X $max = $#dbline;
X if (($stop,$action) = split(/\0/,$dbline{$line})) {
X if ($stop eq '1') {
X $signal |= 1;
X }
X else {
X $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
X $dbline{$line} =~ s/;9($|\0)/$1/;
X }
X }
X if ($single || $trace || $signal) {
X print OUT "$package'" unless $sub =~ /'/;
X print OUT "$sub($filename:$line):\t",$dbline[$line];
X for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
X last if $dbline[$i] =~ /^\s*(}|#|\n)/;
X print OUT "$sub($filename:$i):\t",$dbline[$i];
X }
X }
X $evalarg = $action, &eval if $action;
X if ($single || $signal) {
X $evalarg = $pre, &eval if $pre;
X print OUT $#stack . " levels deep in subroutine calls!\n"
X if $single & 4;
X $start = $line;
X CMD:
X while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
X {
X $single = 0;
X $signal = 0;
X $cmd eq '' && exit 0;
X chop($cmd);
X $cmd =~ s/\\$// && do {
X print OUT " cont: ";
X $cmd .= &gets;
X redo CMD;
X };
X $cmd =~ /^q$/ && exit 0;
X $cmd =~ /^$/ && ($cmd = $laststep);
X push(@hist,$cmd) if length($cmd) > 1;
X ($i) = split(/\s+/,$cmd);
X eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
X $cmd =~ /^h$/ && do {
X print OUT "
XT Stack trace.
Xs Single step.
Xn Next, steps over subroutine calls.
Xr Return from current subroutine.
Xc [line] Continue; optionally inserts a one-time-only breakpoint
X at the specified line.
X<CR> Repeat last n or s.
Xl min+incr List incr+1 lines starting at min.
Xl min-max List lines.
Xl line List line;
Xl List next window.
X- List previous window.
Xw line List window around line.
Xl subname List subroutine.
Xf filename Switch to filename.
X/pattern/ Search forwards for pattern; final / is optional.
X?pattern? Search backwards for pattern.
XL List breakpoints and actions.
XS List subroutine names.
Xt Toggle trace mode.
Xb [line] [condition]
X Set breakpoint; line defaults to the current execution line;
X condition breaks if it evaluates to true, defaults to \'1\'.
Xb subname [condition]
X Set breakpoint at first line of subroutine.
Xd [line] Delete breakpoint.
XD Delete all breakpoints.
Xa [line] command
X Set an action to be done before the line is executed.
X Sequence is: check for breakpoint, print line if necessary,
X do action, prompt user if breakpoint or step, evaluate line.
XA Delete all actions.
XV [pkg [vars]] List some (default all) variables in package (default current).
XX [vars] Same as \"V currentpackage [vars]\".
X< command Define command before prompt.
X> command Define command after prompt.
X! number Redo command (default previous command).
X! -number Redo number\'th to last command.
XH -number Display last number commands (default all).
Xq or ^D Quit.
Xp expr Same as \"print DB'OUT expr\" in current package.
X= [alias value] Define a command alias, or list current aliases.
Xcommand Execute as a perl statement in current package.
X
X";
X next CMD; };
X $cmd =~ /^t$/ && do {
X $trace = !$trace;
X print OUT "Trace = ".($trace?"on":"off")."\n";
X next CMD; };
X $cmd =~ /^S$/ && do {
X foreach $subname (sort(keys %sub)) {
X print OUT $subname,"\n";
X }
X next CMD; };
X $cmd =~ s/^X\b/V $package/;
X $cmd =~ /^V$/ && do {
X $cmd = 'V $package'; };
X $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
X $packname = $1;
X @vars = split(' ',$2);
X do 'dumpvar.pl' unless defined &main'dumpvar;
X if (defined &main'dumpvar) {
X &main'dumpvar($packname,@vars);
X }
X else {
X print DB'OUT "dumpvar.pl not available.\n";
X }
X next CMD; };
X $cmd =~ /^f\b\s*(.*)/ && do {
X $file = $1;
X if (!$file) {
X print OUT "The old f command is now the r command.\n";
X print OUT "The new f command switches filenames.\n";
X next CMD;
X }
X if (!defined $_main{'_<' . $file}) {
X if (($try) = grep(m#^_<.*$file#, keys %_main)) {
X $file = substr($try,2);
X print "\n$file:\n";
X }
X }
X if (!defined $_main{'_<' . $file}) {
X print OUT "There's no code here anything matching $file.\n";
X next CMD;
X }
X elsif ($file ne $filename) {
X *dbline = "_<$file";
X $max = $#dbline;
X $filename = $file;
X $start = 1;
X $cmd = "l";
X } };
X $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
X $subname = $1;
X $subname = "main'" . $subname unless $subname =~ /'/;
X $subname = "main" . $subname if substr($subname,0,1) eq "'";
X ($file,$subrange) = split(/:/,$sub{$subname});
X if ($file ne $filename) {
X *dbline = "_<$file";
X $max = $#dbline;
X $filename = $file;
X }
X if ($subrange) {
X if (eval($subrange) < -$window) {
X $subrange =~ s/-.*/+/;
X }
X $cmd = "l $subrange";
X } else {
X print OUT "Subroutine $1 not found.\n";
X next CMD;
X } };
X $cmd =~ /^w\b\s*(\d*)$/ && do {
X $incr = $window - 1;
X $start = $1 if $1;
X $start -= $preview;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^-$/ && do {
X $incr = $window - 1;
X $cmd = 'l ' . ($start-$window*2) . '+'; };
X $cmd =~ /^l$/ && do {
X $incr = $window - 1;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
X $start = $1 if $1;
X $incr = $2;
X $incr = $window - 1 unless $incr;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
X $end = (!$2) ? $max : ($4 ? $4 : $2);
X $end = $max if $end > $max;
X $i = $2;
X $i = $line if $i eq '.';
X $i = 1 if $i < 1;
X for (; $i <= $end; $i++) {
X print OUT "$i:\t", $dbline[$i];
X last if $signal;
X }
X $start = $i; # remember in case they want more
X $start = $max if $start > $max;
X next CMD; };
X $cmd =~ /^D$/ && do {
X print OUT "Deleting all breakpoints...\n";
X for ($i = 1; $i <= $max ; $i++) {
X if (defined $dbline{$i}) {
X $dbline{$i} =~ s/^[^\0]+//;
X if ($dbline{$i} =~ s/^\0?$//) {
X delete $dbline{$i};
X }
X }
X }
X next CMD; };
X $cmd =~ /^L$/ && do {
X for ($i = 1; $i <= $max; $i++) {
X if (defined $dbline{$i}) {
X print OUT "$i:\t", $dbline[$i];
X ($stop,$action) = split(/\0/, $dbline{$i});
X print OUT " break if (", $stop, ")\n"
X if $stop;
X print OUT " action: ", $action, "\n"
X if $action;
X last if $signal;
X }
X }
X next CMD; };
X $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
X $subname = $1;
X $cond = $2 || '1';
X $subname = "$package'" . $subname unless $subname =~ /'/;
X $subname = "main" . $subname if substr($subname,0,1) eq "'";
X ($filename,$i) = split(/[:-]/, $sub{$subname});
X if ($i) {
X *dbline = "_<$filename";
X ++$i while $dbline[$i] == 0 && $i < $#dbline;
X $dbline{$i} =~ s/^[^\0]*/$cond/;
X } else {
X print OUT "Subroutine $subname not found.\n";
X }
X next CMD; };
X $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
X $i = ($1?$1:$line);
X $cond = $2 || '1';
X if ($dbline[$i] == 0) {
X print OUT "Line $i not breakable.\n";
X } else {
X $dbline{$i} =~ s/^[^\0]*/$cond/;
X }
X next CMD; };
X $cmd =~ /^d\b\s*(\d+)?/ && do {
X $i = ($1?$1:$line);
X $dbline{$i} =~ s/^[^\0]*//;
X delete $dbline{$i} if $dbline{$i} eq '';
X next CMD; };
X $cmd =~ /^A$/ && do {
X for ($i = 1; $i <= $max ; $i++) {
X if (defined $dbline{$i}) {
X $dbline{$i} =~ s/\0[^\0]*//;
X delete $dbline{$i} if $dbline{$i} eq '';
X }
X }
X next CMD; };
X $cmd =~ /^<\s*(.*)/ && do {
X $pre = do action($1);
X next CMD; };
X $cmd =~ /^>\s*(.*)/ && do {
X $post = do action($1);
X next CMD; };
X $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
X $i = $1;
X if ($dbline[$i] == 0) {
X print OUT "Line $i may not have an action.\n";
X } else {
X $dbline{$i} =~ s/\0[^\0]*//;
X $dbline{$i} .= "\0" . do action($3);
X }
X next CMD; };
X $cmd =~ /^n$/ && do {
X $single = 2;
X $laststep = $cmd;
X last CMD; };
X $cmd =~ /^s$/ && do {
X $single = 1;
X $laststep = $cmd;
X last CMD; };
X $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
X $i = $1;
X if ($i) {
X if ($dbline[$i] == 0) {
X print OUT "Line $i not breakable.\n";
X next CMD;
X }
X $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
X }
X for ($i=0; $i <= $#stack; ) {
X $stack[$i++] &= ~1;
X }
X last CMD; };
X $cmd =~ /^r$/ && do {
X $stack[$#stack] |= 2;
X last CMD; };
X $cmd =~ /^T$/ && do {
X local($p,$f,$l,$s,$h,$a,@a,@sub);
X for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
X @a = @args;
X for (@a) {
X if (/^StB\000/ && length($_) == length($_main{'_main'})) {
X $_ = sprintf("%s",$_);
X }
X else {
X s/'/\\'/g;
X s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
X s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
X s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
X }
X }
X $w = $w ? '@ = ' : '$ = ';
X $a = $h ? '(' . join(', ', @a) . ')' : '';
X push(@sub, "$w&$s$a from file $f line $l\n");
X last if $signal;
X }
X for ($i=0; $i <= $#sub; $i++) {
X last if $signal;
X print OUT $sub[$i];
X }
X next CMD; };
X $cmd =~ /^\/(.*)$/ && do {
X $inpat = $1;
X $inpat =~ s:([^\\])/$:$1:;
X if ($inpat ne "") {
X eval '$inpat =~ m'."\n$inpat\n";
X if ($@ ne "") {
X print OUT "$@";
X next CMD;
X }
X $pat = $inpat;
X }
X $end = $start;
X eval '
X for (;;) {
X ++$start;
X $start = 1 if ($start > $max);
X last if ($start == $end);
X if ($dbline[$start] =~ m'."\n$pat\n".'i) {
X print OUT "$start:\t", $dbline[$start], "\n";
X last;
X }
X } ';
X print OUT "/$pat/: not found\n" if ($start == $end);
X next CMD; };
X $cmd =~ /^\?(.*)$/ && do {
X $inpat = $1;
X $inpat =~ s:([^\\])\?$:$1:;
X if ($inpat ne "") {
X eval '$inpat =~ m'."\n$inpat\n";
X if ($@ ne "") {
X print OUT "$@";
X next CMD;
X }
X $pat = $inpat;
X }
X $end = $start;
X eval '
X for (;;) {
X --$start;
X $start = $max if ($start <= 0);
X last if ($start == $end);
X if ($dbline[$start] =~ m'."\n$pat\n".'i) {
X print OUT "$start:\t", $dbline[$start], "\n";
X last;
X }
X } ';
X print OUT "?$pat?: not found\n" if ($start == $end);
X next CMD; };
X $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
X pop(@hist) if length($cmd) > 1;
X $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
X $cmd = $hist[$i] . "\n";
X print OUT $cmd;
X redo CMD; };
X $cmd =~ /^!(.+)$/ && do {
X $pat = "^$1";
X pop(@hist) if length($cmd) > 1;
X for ($i = $#hist; $i; --$i) {
X last if $hist[$i] =~ $pat;
X }
X if (!$i) {
X print OUT "No such command!\n\n";
X next CMD;
X }
X $cmd = $hist[$i] . "\n";
X print OUT $cmd;
X redo CMD; };
X $cmd =~ /^H\b\s*(-(\d+))?/ && do {
X $end = $2?($#hist-$2):0;
X $hist = 0 if $hist < 0;
X for ($i=$#hist; $i>$end; $i--) {
X print OUT "$i: ",$hist[$i],"\n"
X unless $hist[$i] =~ /^.?$/;
X };
X next CMD; };
X $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
X $cmd =~ /^=/ && do {
X if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
X $alias{$k}="s~$k~$v~";
X print OUT "$k = $v\n";
X } elsif ($cmd =~ /^=\s*$/) {
X foreach $k (sort keys(%alias)) {
X if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
X print OUT "$k = $v\n";
X } else {
X print OUT "$k\t$alias{$k}\n";
X };
X };
X };
X next CMD; };
X }
X $evalarg = $cmd; &eval;
X print OUT "\n";
X }
X if ($post) {
X $evalarg = $post; &eval;
X }
X }
X ($@, $!, $[, $,, $/, $\) = @saved;
X}
X
Xsub save {
X @saved = ($@, $!, $[, $,, $/, $\);
X $[ = 0; $, = ""; $/ = "\n"; $\ = "";
X}
X
X# The following takes its argument via $evalarg to preserve current @_
X
Xsub eval {
X eval "$usercontext $evalarg; &DB'save";
X print OUT $@;
X}
X
Xsub action {
X local($action) = @_;
X while ($action =~ s/\\$//) {
X print OUT "+ ";
X $action .= &gets;
X }
X $action;
X}
X
Xsub gets {
X local($.);
X <IN>;
X}
X
Xsub catch {
X $signal = 1;
X}
X
Xsub sub {
X push(@stack, $single);
X $single &= 1;
X $single |= 4 if $#stack == $deep;
X if (wantarray) {
X @i = &$sub;
X $single |= pop(@stack);
X @i;
X }
X else {
X $i = &$sub;
X $single |= pop(@stack);
X $i;
X }
X}
X
X$single = 1; # so it stops on first executable statement
X@hist = ('?');
X$SIG{'INT'} = "DB'catch";
X$deep = 100; # warning if stack gets this deep
X$window = 10;
X$preview = 3;
X
X@stack = (0);
X@ARGS = @ARGV;
Xfor (@args) {
X s/'/\\'/g;
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X}
X
Xif (-f '.perldb') {
X do './.perldb';
X}
Xelsif (-f "$ENV{'LOGDIR'}/.perldb") {
X do "$ENV{'LOGDIR'}/.perldb";
X}
Xelsif (-f "$ENV{'HOME'}/.perldb") {
X do "$ENV{'HOME'}/.perldb";
X}
X
X1;
!STUFFY!FUNK!
echo Extracting hash.c
sed >hash.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.c,v 4.0 91/03/20 01:22:26 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: hash.c,v $
X * Revision 4.0 91/03/20 01:22:26 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
Xstatic char coeff[] = {
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
X
Xstatic void hfreeentries();
X
XSTR *
Xhfetch(tb,key,klen,lval)
Xregister HASH *tb;
Xchar *key;
Xunsigned int klen;
Xint lval;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register int maxi;
X STR *str;
X#ifdef SOME_DBM
X datum dkey,dcontent;
X#endif
X
X if (!tb)
X return &str_undef;
X if (!tb->tbl_array) {
X if (lval)
X Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
X else
X return &str_undef;
X }
X
X /* The hash function we use on symbols has to be equal to the first
X * character when taken modulo 128, so that str_reset() can be implemented
X * efficiently. We throw in the second character and the last character
X * (times 128) so that long chains of identifiers starting with the
X * same letter don't have to be strEQ'ed within hfetch(), since it
X * compares hash values before trying strEQ().
X */
X if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X }
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 (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X return entry->hent_val;
X }
X#ifdef SOME_DBM
X if (tb->tbl_dbm) {
X dkey.dptr = key;
X dkey.dsize = klen;
X#ifdef HAS_GDBM
X dcontent = gdbm_fetch(tb->tbl_dbm,dkey);
X#else
X dcontent = dbm_fetch(tb->tbl_dbm,dkey);
X#endif
X if (dcontent.dptr) { /* found one */
X str = Str_new(60,dcontent.dsize);
X str_nset(str,dcontent.dptr,dcontent.dsize);
X hstore(tb,key,klen,str,hash); /* cache it */
X return str;
X }
X }
X#endif
X if (lval) { /* gonna assign to this, so it better be there */
X str = Str_new(61,0);
X hstore(tb,key,klen,str,hash);
X return str;
X }
X return &str_undef;
X}
X
Xbool
Xhstore(tb,key,klen,val,hash)
Xregister HASH *tb;
Xchar *key;
Xunsigned int klen;
XSTR *val;
Xregister int hash;
X{
X register char *s;
X register int i;
X register HENT *entry;
X register HENT **oentry;
X register int maxi;
X
X if (!tb)
X return FALSE;
X
X if (hash)
X ;
X else if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1];
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X }
X
X if (!tb->tbl_array)
X Newz(505,tb->tbl_array, tb->tbl_max + 1, HENT*);
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 (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X Safefree(entry->hent_val);
X entry->hent_val = val;
X return TRUE;
X }
X New(501,entry, 1, HENT);
X
X entry->hent_klen = klen;
X entry->hent_key = nsavestr(key,klen);
X entry->hent_val = val;
X entry->hent_hash = hash;
X entry->hent_next = *oentry;
X *oentry = entry;
X
X /* hdbmstore not necessary here because it's called from stabset() */
X
X if (i) { /* initial entry? */
X tb->tbl_fill++;
X#ifdef SOME_DBM
X if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX)
X return FALSE;
X#endif
X if (tb->tbl_fill > tb->tbl_dosplit)
X hsplit(tb);
X }
X#ifdef SOME_DBM
X else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */
X void hentdelayfree();
X
X entry = tb->tbl_array[hash & tb->tbl_max];
X oentry = &entry->hent_next;
X entry = *oentry;
X while (entry) { /* trim chain down to 1 entry */
X *oentry = entry->hent_next;
X hentdelayfree(entry); /* no doubt they'll want this next. */
X entry = *oentry;
X }
X }
X#endif
X
X return FALSE;
X}
X
XSTR *
Xhdelete(tb,key,klen)
Xregister HASH *tb;
Xchar *key;
Xunsigned int klen;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X STR *str;
X int maxi;
X#ifdef SOME_DBM
X datum dkey;
X#endif
X
X if (!tb || !tb->tbl_array)
X return Nullstr;
X if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1];
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
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 = *oentry) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X *oentry = entry->hent_next;
X str = str_mortal(entry->hent_val);
X hentfree(entry);
X if (i)
X tb->tbl_fill--;
X#ifdef SOME_DBM
X do_dbm_delete:
X if (tb->tbl_dbm) {
X dkey.dptr = key;
X dkey.dsize = klen;
X#ifdef HAS_GDBM
X gdbm_delete(tb->tbl_dbm,dkey);
X#else
X dbm_delete(tb->tbl_dbm,dkey);
X#endif
X }
X#endif
X return str;
X }
X#ifdef SOME_DBM
X str = Nullstr;
X goto do_dbm_delete;
X#else
X return Nullstr;
X#endif
X}
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 = tb->tbl_array;
X Renew(a, newsize, HENT*);
X Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/
X tb->tbl_max = --newsize;
X tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
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(lookat)
Xunsigned int lookat;
X{
X register HASH *tb;
X
X Newz(502,tb, 1, HASH);
X if (lookat) {
X tb->tbl_coeffsize = lookat;
X tb->tbl_max = 7; /* it's a normal associative array */
X tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
X }
X else {
X tb->tbl_max = 127; /* it's a symbol table */
X tb->tbl_dosplit = 128; /* so never split */
X }
X tb->tbl_fill = 0;
X#ifdef SOME_DBM
X tb->tbl_dbm = 0;
X#endif
X (void)hiterinit(tb); /* so each() will start off right */
X return tb;
X}
X
Xvoid
Xhentfree(hent)
Xregister HENT *hent;
X{
X if (!hent)
X return;
X str_free(hent->hent_val);
X Safefree(hent->hent_key);
X Safefree(hent);
X}
X
Xvoid
Xhentdelayfree(hent)
Xregister HENT *hent;
X{
X if (!hent)
X return;
X str_2mortal(hent->hent_val); /* free between statements */
X Safefree(hent->hent_key);
X Safefree(hent);
X}
X
Xvoid
Xhclear(tb,dodbm)
Xregister HASH *tb;
Xint dodbm;
X{
X if (!tb)
X return;
X hfreeentries(tb,dodbm);
X tb->tbl_fill = 0;
X#ifndef lint
X if (tb->tbl_array)
X (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
X#endif
X}
X
Xstatic void
Xhfreeentries(tb,dodbm)
Xregister HASH *tb;
Xint dodbm;
X{
X register HENT *hent;
X register HENT *ohent = Null(HENT*);
X#ifdef SOME_DBM
X datum dkey;
X datum nextdkey;
X#ifdef HAS_GDBM
X GDBM_FILE old_dbm;
X#else
X#ifdef HAS_NDBM
X DBM *old_dbm;
X#else
X int old_dbm;
X#endif
X#endif
X#endif
X
X if (!tb || !tb->tbl_array)
X return;
X#ifdef SOME_DBM
X if ((old_dbm = tb->tbl_dbm) && dodbm) {
X#ifdef HAS_GDBM
X while (dkey = gdbm_firstkey(tb->tbl_dbm), dkey.dptr) {
X#else
X while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) {
X#endif
X do {
X#ifdef HAS_GDBM
X nextdkey = gdbm_nextkey(tb->tbl_dbm, dkey);
X#else
X#ifdef HAS_NDBM
X#ifdef _CX_UX
X nextdkey = dbm_nextkey(tb->tbl_dbm, dkey);
X#else
X nextdkey = dbm_nextkey(tb->tbl_dbm);
X#endif
X#else
X nextdkey = nextkey(dkey);
X#endif
X#endif
X#ifdef HAS_GDBM
X gdbm_delete(tb->tbl_dbm,dkey);
X#else
X dbm_delete(tb->tbl_dbm,dkey);
X#endif
X dkey = nextdkey;
X } while (dkey.dptr); /* one way or another, this works */
X }
X }
X tb->tbl_dbm = 0; /* now clear just cache */
X#endif
X (void)hiterinit(tb);
X while (hent = hiternext(tb)) { /* concise but not very efficient */
X hentfree(ohent);
X ohent = hent;
X }
X hentfree(ohent);
X#ifdef SOME_DBM
X tb->tbl_dbm = old_dbm;
X#endif
X}
X
Xvoid
Xhfree(tb,dodbm)
Xregister HASH *tb;
Xint dodbm;
X{
X if (!tb)
X return;
X hfreeentries(tb,dodbm);
X Safefree(tb->tbl_array);
X Safefree(tb);
X}
X
Xint
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#ifdef SOME_DBM
X datum key;
X#endif
X
X entry = tb->tbl_eiter;
X#ifdef SOME_DBM
X if (tb->tbl_dbm) {
X if (entry) {
X#ifdef HAS_GDBM
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X key = gdbm_nextkey(tb->tbl_dbm, key);
X#else
X#ifdef HAS_NDBM
X#ifdef _CX_UX
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X key = dbm_nextkey(tb->tbl_dbm, key);
X#else
X key = dbm_nextkey(tb->tbl_dbm);
X#endif /* _CX_UX */
X#else
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X key = nextkey(key);
X#endif
X#endif
X }
X else {
X Newz(504,entry, 1, HENT);
X tb->tbl_eiter = entry;
X#ifdef HAS_GDBM
X key = gdbm_firstkey(tb->tbl_dbm);
X#else
X key = dbm_firstkey(tb->tbl_dbm);
X#endif
X }
X entry->hent_key = key.dptr;
X entry->hent_klen = key.dsize;
X if (!key.dptr) {
X if (entry->hent_val)
X str_free(entry->hent_val);
X Safefree(entry);
X tb->tbl_eiter = Null(HENT*);
X return Null(HENT*);
X }
X return entry;
X }
X#endif
X if (!tb->tbl_array)
X Newz(506,tb->tbl_array, tb->tbl_max + 1, HENT*);
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,retlen)
Xregister HENT *entry;
Xint *retlen;
X{
X *retlen = entry->hent_klen;
X return entry->hent_key;
X}
X
XSTR *
Xhiterval(tb,entry)
Xregister HASH *tb;
Xregister HENT *entry;
X{
X#ifdef SOME_DBM
X datum key, content;
X
X if (tb->tbl_dbm) {
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X#ifdef HAS_GDBM
X content = gdbm_fetch(tb->tbl_dbm,key);
X#else
X content = dbm_fetch(tb->tbl_dbm,key);
X#endif
X if (!entry->hent_val)
X entry->hent_val = Str_new(62,0);
X str_nset(entry->hent_val,content.dptr,content.dsize);
X }
X#endif
X return entry->hent_val;
X}
X
X#ifdef SOME_DBM
X
X#ifndef O_CREAT
X# ifdef I_FCNTL
X# include <fcntl.h>
X# endif
X# ifdef I_SYS_FILE
X# include <sys/file.h>
X# endif
X#endif
X
X#ifndef O_RDONLY
X#define O_RDONLY 0
X#endif
X#ifndef O_RDWR
X#define O_RDWR 2
X#endif
X#ifndef O_CREAT
X#define O_CREAT 01000
X#endif
X
X#ifdef HAS_ODBM
Xstatic int dbmrefcnt = 0;
X#endif
X
Xbool
Xhdbmopen(tb,fname,mode)
Xregister HASH *tb;
Xchar *fname;
Xint mode;
X{
X if (!tb)
X return FALSE;
X#ifdef HAS_ODBM
X if (tb->tbl_dbm) /* never really closed it */
X return TRUE;
X#endif
X if (tb->tbl_dbm) {
X hdbmclose(tb);
X tb->tbl_dbm = 0;
X }
X hclear(tb, FALSE); /* clear cache */
X#ifdef HAS_GDBM
X if (mode >= 0)
X tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL);
X if (!tb->tbl_dbm)
X tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL);
X if (!tb->tbl_dbm)
X tb->tbl_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL);
X#else
X#ifdef HAS_NDBM
X if (mode >= 0)
X tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
X if (!tb->tbl_dbm)
X tb->tbl_dbm = dbm_open(fname, O_RDWR, mode);
X if (!tb->tbl_dbm)
X tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
X#else
X if (dbmrefcnt++)
X fatal("Old dbm can only open one database");
X sprintf(buf,"%s.dir",fname);
X if (stat(buf, &statbuf) < 0) {
X if (mode < 0 || close(creat(buf,mode)) < 0)
X return FALSE;
X sprintf(buf,"%s.pag",fname);
X if (close(creat(buf,mode)) < 0)
X return FALSE;
X }
X tb->tbl_dbm = dbminit(fname) >= 0;
X#endif
X#endif
X if (!tb->tbl_array && tb->tbl_dbm != 0)
X Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*);
X return tb->tbl_dbm != 0;
X}
X
Xvoid
Xhdbmclose(tb)
Xregister HASH *tb;
X{
X if (tb && tb->tbl_dbm) {
X#ifdef HAS_GDBM
X gdbm_close(tb->tbl_dbm);
X tb->tbl_dbm = 0;
X#else
X#ifdef HAS_NDBM
X dbm_close(tb->tbl_dbm);
X tb->tbl_dbm = 0;
X#else
X /* dbmrefcnt--; */ /* doesn't work, rats */
X#endif
X#endif
X }
X else if (dowarn)
X warn("Close on unopened dbm file");
X}
X
Xbool
Xhdbmstore(tb,key,klen,str)
Xregister HASH *tb;
Xchar *key;
Xunsigned int klen;
Xregister STR *str;
X{
X datum dkey, dcontent;
X int error;
X
X if (!tb || !tb->tbl_dbm)
X return FALSE;
X dkey.dptr = key;
X dkey.dsize = klen;
X dcontent.dptr = str_get(str);
X dcontent.dsize = str->str_cur;
X#ifdef HAS_GDBM
X error = gdbm_store(tb->tbl_dbm, dkey, dcontent, GDBM_REPLACE);
X#else
X error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
X#endif
X if (error) {
X if (errno == EPERM)
X fatal("No write permission to dbm file");
X warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
X#ifdef HAS_NDBM
X dbm_clearerr(tb->tbl_dbm);
X#endif
X }
X return !error;
X}
X#endif /* SOME_DBM */
!STUFFY!FUNK!
echo Extracting x2p/find2perl.SH
sed >x2p/find2perl.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase $CONFIG in
X'')
X if test ! -f config.sh; then
X ln ../config.sh . || \
X ln ../../config.sh . || \
X ln ../../../config.sh . || \
X (echo "Can't find config.sh."; exit 1)
X fi
X . config.sh
X ;;
Xesac
X: This forces SH files to create target in same directory as SH file.
X: This is so that make depend always knows where to find SH derivatives.
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xecho "Extracting find2perl (with variable substitutions)"
X: This section of the file will have variable substitutions done on it.
X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
X: Protect any dollar signs and backticks that you do not want interpreted
X: by putting a backslash in front. You may delete these comments.
X$spitshell >find2perl <<!GROK!THIS!
X#!$bin/perl
X
X\$bin = "$bin";
X
X!GROK!THIS!
X
X: In the following dollars and backticks do not need the extra backslash.
X$spitshell >>find2perl <<'!NO!SUBS!'
X
Xwhile ($ARGV[0] =~ /^[^-!(]/) {
X push(@roots, shift);
X}
X@roots = ('.') unless @roots;
Xfor (@roots) { $_ = "e($_); }
X$roots = join(',', @roots);
X
X$indent = 1;
X
Xwhile (@ARGV) {
X $_ = shift;
X s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
X if ($_ eq '(') {
X $out .= &tab . "(\n";
X $indent++;
X next;
X }
X elsif ($_ eq ')') {
X $indent--;
X $out .= &tab . ")";
X }
X elsif ($_ eq '!') {
X $out .= &tab . "!";
X next;
X }
X elsif ($_ eq 'name') {
X $out .= &tab;
X $pat = &fileglob_to_re(shift);
X $out .= '/' . $pat . "/";
X }
X elsif ($_ eq 'perm') {
X $onum = shift;
X die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
X if ($onum =~ s/^-//) {
X $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ?
X $out .= &tab . "(\$mode & $onum) == $onum";
X }
X else {
X $onum = '0' . $onum unless $onum =~ /^0/;
X $out .= &tab . "(\$mode & 0777) == $onum";
X }
X }
X elsif ($_ eq 'type') {
X ($filetest = shift) =~ tr/s/S/;
X $out .= &tab . "-$filetest _";
X }
X elsif ($_ eq 'print') {
X $out .= &tab . 'print("$name\n")';
X }
X elsif ($_ eq 'print0') {
X $out .= &tab . 'print("$name\0")';
X }
X elsif ($_ eq 'fstype') {
X $out .= &tab;
X $type = shift;
X if ($type eq 'nfs')
X { $out .= '$dev < 0'; }
X else
X { $out .= '$dev >= 0'; }
X }
X elsif ($_ eq 'user') {
X $uname = shift;
X $out .= &tab . "\$uid == \$uid{'$uname'}";
X $inituser++;
X }
X elsif ($_ eq 'group') {
X $gname = shift;
X $out .= &tab . "\$gid == \$gid('$gname')";
X $initgroup++;
X }
X elsif ($_ eq 'nouser') {
X $out .= &tab . '!defined $uid{$uid}';
X $inituser++;
X }
X elsif ($_ eq 'nogroup') {
X $out .= &tab . '!defined $gid{$gid}';
X $initgroup++;
X }
X elsif ($_ eq 'links') {
X $out .= &tab . '$nlink ' . &n(shift);
X }
X elsif ($_ eq 'inum') {
X $out .= &tab . '$ino ' . &n(shift);
X }
X elsif ($_ eq 'size') {
X $out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
X }
X elsif ($_ eq 'atime') {
X $out .= &tab . 'int(-A _) ' . &n(shift);
X }
X elsif ($_ eq 'mtime') {
X $out .= &tab . 'int(-M _) ' . &n(shift);
X }
X elsif ($_ eq 'ctime') {
X $out .= &tab . 'int(-C _) ' . &n(shift);
X }
X elsif ($_ eq 'exec') {
X for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
X shift;
X for (@cmd) { s/'/\\'/g; }
X $" = "','";
X $out .= &tab . "&exec(0, '@cmd')";
X $" = ' ';
X $initexec++;
X }
X elsif ($_ eq 'ok') {
X for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
X shift;
X for (@cmd) { s/'/\\'/g; }
X $" = "','";
X $out .= &tab . "&exec(1, '@cmd')";
X $" = ' ';
X $initexec++;
X }
X elsif ($_ eq 'prune') {
X $out .= &tab . '($prune = 1)';
X }
X elsif ($_ eq 'xdev') {
X $out .= &tab . '(($prune |= ($dev != $topdev)),1)';
X }
X elsif ($_ eq 'newer') {
X $out .= &tab;
X $file = shift;
X $newername = 'AGE_OF' . $file;
X $newername =~ s/[^\w]/_/g;
X $newername = '$' . $newername;
X $out .= "-M _ < $newername";
X $initnewer .= "$newername = -M " . "e($file) . ";\n";
X }
X elsif ($_ eq 'eval') {
X $prog = "e(shift);
X $out .= &tab . "eval $prog";
X }
X elsif ($_ eq 'depth') {
X $depth++;
X next;
X }
X elsif ($_ eq 'ls') {
X $out .= &tab . "&ls";
X $initls++;
X }
X elsif ($_ eq 'tar') {
X $out .= &tab;
X die "-tar must have a filename argument\n" unless @ARGV;
X $file = shift;
X $fh = 'FH' . $file;
X $fh =~ s/[^\w]/_/g;
X $out .= "&tar($fh)";
X $file = '>' . $file;
X $initfile .= "open($fh, " . "e($file) .
X qq{) || die "Can't open $fh: \$!\\n";\n};
X $inittar++;
X $flushall = "\n&tflushall;\n";
X }
X elsif (/^n?cpio$/) {
X $depth++;
X $out .= &tab;
X die "-$_ must have a filename argument\n" unless @ARGV;
X $file = shift;
X $fh = 'FH' . $file;
X $fh =~ s/[^\w]/_/g;
X $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
X $file = '>' . $file;
X $initfile .= "open($fh, " . "e($file) .
X qq{) || die "Can't open $fh: \$!\\n";\n};
X $initcpio++;
X $flushall = "\n&flushall;\n";
X }
X else {
X die "Unrecognized switch: -$_\n";
X }
X if (@ARGV) {
X if ($ARGV[0] eq '-o') {
X $statdone = 0 if $indent == 1 && $delayedstat;
X $saw_or++;
X $out .= "\n" . &tab . "||\n";
X shift;
X }
X else {
X $out .= " &&" unless $ARGV[0] eq ')';
X $out .= "\n";
X shift if $ARGV[0] eq '-a';
X }
X }
X}
X
Xprint <<"END";
X#!$bin/perl
X
XEND
X
Xif ($initls) {
X print <<'END';
X@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
X@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
X
XEND
X}
X
Xif ($inituser || $initls) {
X print 'while (($name, $pw, $uid) = getpwent) {', "\n";
X print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
X print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
X print "}\n\n";
X}
X
Xif ($initgroup || $initls) {
X print 'while (($name, $pw, $gid) = getgrent) {', "\n";
X print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
X print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
X print "}\n\n";
X}
X
Xprint $initnewer, "\n" if $initnewer;
X
Xprint $initfile, "\n" if $initfile;
X
Xprint <<"END";
X# Traverse desired filesystems
X
X&dodirs($roots);
X$flushall
Xexit;
X
Xsub wanted {
X$out;
X}
X
XEND
X
Xprint <<'END';
Xsub dodirs {
X chop($cwd = `pwd`);
X foreach $topdir (@_) {
X (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
X || (warn("Can't stat $topdir: $!\n"), next);
X if (-d _) {
X if (chdir($topdir)) {
XEND
Xif ($depth) {
X print <<'END';
X $topdir = '' if $topdir eq '/';
X &dodir($topdir,$topnlink);
X ($dir,$_) = ($topdir,'.');
X $name = $topdir;
X &wanted;
XEND
X}
Xelse {
X print <<'END';
X ($dir,$_) = ($topdir,'.');
X $name = $topdir;
X &wanted;
X $topdir = '' if $topdir eq '/';
X &dodir($topdir,$topnlink);
XEND
X}
Xprint <<'END';
X }
X else {
X warn "Can't cd to $topdir: $!\n";
X }
X }
X else {
X unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
X ($dir,$_) = ('.', $topdir);
X }
X chdir $dir && &wanted;
X }
X chdir $cwd;
X }
X}
X
Xsub dodir {
X local($dir,$nlink) = @_;
X local($dev,$ino,$mode,$subcount);
X local($name);
X
X # Get the list of files in the current directory.
X
X opendir(DIR,'.') || warn "Can't open $dir: $!\n";
X local(@filenames) = readdir(DIR);
X closedir(DIR);
X
X if ($nlink == 2) { # This dir has no subdirectories.
X for (@filenames) {
X next if $_ eq '.';
X next if $_ eq '..';
X $name = "$dir/$_";
X $nlink = 0;
X &wanted;
X }
X }
X else { # This dir has subdirectories.
X $subcount = $nlink - 2;
X for (@filenames) {
X next if $_ eq '.';
X next if $_ eq '..';
X $nlink = $prune = 0;
X $name = "$dir/$_";
XEND
Xprint <<'END' unless $depth;
X &wanted;
XEND
Xprint <<'END';
X if ($subcount > 0) { # Seen all the subdirs?
X
X # Get link count and check for directoriness.
X
X ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
X
X if (-d _) {
X
X # It really is a directory, so do it recursively.
X
X if (!$prune && chdir $_) {
X &dodir($name,$nlink);
X chdir '..';
X }
X --$subcount;
X }
X }
XEND
Xprint <<'END' if $depth;
X &wanted;
XEND
Xprint <<'END';
X }
X }
X}
X
XEND
X
Xif ($initexec) {
X print <<'END';
Xsub exec {
X local($ok, @cmd) = @_;
X foreach $word (@cmd) {
X $word =~ s#{}#$name#g;
X }
X if ($ok) {
X local($old) = select(STDOUT);
X $| = 1;
X print "@cmd";
X select($old);
X return 0 unless <STDIN> =~ /^y/;
X }
X chdir $cwd; # sigh
X system @cmd;
X chdir $dir;
X return !$?;
X}
X
XEND
X}
X
Xif ($initls) {
X print <<'END';
Xsub ls {
X ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
X $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X
X $pname = $name;
X
X if (defined $blocks) {
X $blocks = int(($blocks + 1) / 2);
X }
X else {
X $blocks = int(($size + 1023) / 1024);
X }
X
X if (-f _) { $perms = '-'; }
X elsif (-d _) { $perms = 'd'; }
X elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
X elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
X elsif (-p _) { $perms = 'p'; }
X elsif (-S _) { $perms = 's'; }
X else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
X
X $tmpmode = $mode;
X $tmp = $rwx[$tmpmode & 7];
X $tmpmode >>= 3;
X $tmp = $rwx[$tmpmode & 7] . $tmp;
X $tmpmode >>= 3;
X $tmp = $rwx[$tmpmode & 7] . $tmp;
X substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
X substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
X substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
X $perms .= $tmp;
X
X $user = $user{$uid} || $uid;
X $group = $group{$gid} || $gid;
X
X ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
X $moname = $moname[$mon];
X if (-M _ > 365.25 / 2) {
X $timeyear = '19' . $year;
X }
X else {
X $timeyear = sprintf("%02d:%02d", $hour, $min);
X }
X
X printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
X $ino,
X $blocks,
X $perms,
X $nlink,
X $user,
X $group,
X $sizemm,
X $moname,
X $mday,
X $timeyear,
X $pname;
X 1;
X}
X
Xsub sizemm {
X sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
X}
X
XEND
X}
X
Xif ($initcpio) {
Xprint <<'END';
Xsub cpio {
X local($nc,$fh) = @_;
X local($text);
X
X if ($name eq 'TRAILER!!!') {
X $text = '';
X $size = 0;
X }
X else {
X ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X if (-f _) {
X open(IN, $_) || do {
X warn "Couldn't open $name: $!\n";
X return;
X };
X }
X else {
X $text = readlink($_);
X $size = 0 unless defined $text;
X }
X }
X
X ($nm = $name) =~ s#^\./##;
X $nc{$fh} = $nc;
X if ($nc eq 'n') {
X $cpout{$fh} .=
X sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
X 070707,
X $dev & 0777777,
X $ino & 0777777,
X $mode & 0777777,
X $uid & 0777777,
X $gid & 0777777,
X $nlink & 0777777,
X $rdev & 0177777,
X $mtime,
X length($nm)+1,
X $size,
X $nm);
X }
X else {
X $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
X $cpout{$fh} .= pack("SSSSSSSSLSLa*",
X 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
X length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
X }
X if ($text ne '') {
X $cpout{$fh} .= $text;
X }
X elsif ($size) {
X &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
X while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
X &flush($fh);
X $l = length($cpout{$fh});
X }
X }
X close IN;
X}
X
Xsub flush {
X local($fh) = @_;
X
X while (length($cpout{$fh}) >= 5120) {
X syswrite($fh,$cpout{$fh},5120);
X ++$blocks{$fh};
X substr($cpout{$fh}, 0, 5120) = '';
X }
X}
X
Xsub flushall {
X $name = 'TRAILER!!!';
X foreach $fh (keys %cpout) {
X &cpio($nc{$fh},$fh);
X $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
X &flush($fh);
X print $blocks{$fh} * 10, " blocks\n";
X }
X}
X
XEND
X}
X
Xif ($inittar) {
Xprint <<'END';
Xsub tar {
X local($fh) = @_;
X local($linkname,$header,$l,$slop);
X local($linkflag) = "\0";
X
X ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
X $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
X $nm = $name;
X if ($nlink > 1) {
X if ($linkname = $linkseen{$fh,$dev,$ino}) {
X $linkflag = 1;
X }
X else {
X $linkseen{$fh,$dev,$ino} = $nm;
X }
X }
X if (-f _) {
X open(IN, $_) || do {
X warn "Couldn't open $name: $!\n";
X return;
X };
X $size = 0 if $linkflag ne "\0";
X }
X else {
X $linkname = readlink($_);
X $linkflag = 2 if defined $linkname;
X $nm .= '/' if -d _;
X $size = 0;
X }
X
X $header = pack("a100a8a8a8a12a12a8a1a100",
X $nm,
X sprintf("%6o ", $mode & 0777),
X sprintf("%6o ", $uid & 0777777),
X sprintf("%6o ", $gid & 0777777),
X sprintf("%11o ", $size),
X sprintf("%11o ", $mtime),
X " ",
X $linkflag,
X $linkname);
X $l = length($header) % 512;
X substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
X substr($header, 154, 1) = "\0"; # blech
X $tarout{$fh} .= $header;
X $tarout{$fh} .= "\0" x (512 - $l) if $l;
X if ($size) {
X &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
X while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
X $slop = length($tarout{$fh}) % 512;
X $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
X &tflush($fh);
X $l = length($tarout{$fh});
X }
X }
X close IN;
X}
X
Xsub tflush {
X local($fh) = @_;
X
X while (length($tarout{$fh}) >= 10240) {
X syswrite($fh,$tarout{$fh},10240);
X ++$blocks{$fh};
X substr($tarout{$fh}, 0, 10240) = '';
X }
X}
X
Xsub tflushall {
X local($len);
X
X foreach $fh (keys %tarout) {
X $len = 10240 - length($tarout{$fh});
X $len += 10240 if $len < 1024;
X $tarout{$fh} .= "\0" x $len;
X &tflush($fh);
X }
X}
X
XEND
X}
X
Xexit;
X
X############################################################################
X
Xsub tab {
X local($tabstring);
X
X $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
X if (!$statdone) {
X if ($_ =~ /^(name|print)/) {
X $delayedstat++;
X }
X else {
X if ($saw_or) {
X $tabstring .= <<'ENDOFSTAT' . $tabstring;
X($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
XENDOFSTAT
X }
X else {
X $tabstring .= <<'ENDOFSTAT' . $tabstring;
X(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
XENDOFSTAT
X }
X $statdone = 1;
X }
X }
X $tabstring =~ s/^\s+/ / if $out =~ /!$/;
X $tabstring;
X}
X
Xsub fileglob_to_re {
X local($tmp) = @_;
X
X $tmp =~ s/([.^\$()])/\\$1/g;
X $tmp =~ s/([?*])/.$1/g;
X "^$tmp$";
X}
X
Xsub n {
X local($n) = @_;
X
X $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
X $n =~ s/ 0*(\d)/ $1/;
X $n;
X}
X
Xsub quote {
X local($string) = @_;
X $string =~ s/'/\\'/;
X "'$string'";
X}
X!NO!SUBS!
Xchmod 755 find2perl
X$eunicefix find2perl
!STUFFY!FUNK!
echo Extracting eg/muck
sed >eg/muck <<'!STUFFY!FUNK!' -e 's/X//'
X#!../perl
X
X$M = '-M';
X$M = '-m' if -d '/usr/uts' && -f '/etc/master';
X
Xdo 'getopt.pl';
Xdo Getopt('f');
X
Xif ($opt_f) {
X $makefile = $opt_f;
X}
Xelsif (-f 'makefile') {
X $makefile = 'makefile';
X}
Xelsif (-f 'Makefile') {
X $makefile = 'Makefile';
X}
Xelse {
X die "No makefile\n";
X}
X
X$MF = 'mf00';
X
Xwhile(($key,$val) = each(ENV)) {
X $mac{$key} = $val;
X}
X
Xdo scan($makefile);
X
X$co = $action{'.c.o'};
X$co = ' ' unless $co;
X
X$missing = "Missing dependencies:\n";
Xforeach $key (sort keys(o)) {
X if ($oc{$key}) {
X $src = $oc{$key};
X $action = $action{$key};
X }
X else {
X $action = '';
X }
X if (!$action) {
X if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
X $src = $c;
X $action = $co;
X }
X else {
X print "No source found for $key $c\n";
X next;
X }
X }
X $I = '';
X $D = '';
X $I .= $1 while $action =~ s/(-I\S+\s*)//;
X $D .= $1 . ' ' while $action =~ s/(-D\w+)//;
X if ($opt_v) {
X $cmd = "Checking $key: cc $M $D $I $src";
X $cmd =~ s/\s\s+/ /g;
X print stderr $cmd,"\n";
X }
X open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
X while (<CPP>) {
X ($name,$dep) = split;
X $dep =~ s|^\./||;
X (print $missing,"$key: $dep\n"),($missing='')
X unless ($dep{"$key: $dep"} += 2) > 2;
X }
X}
X
X$extra = "\nExtraneous dependencies:\n";
Xforeach $key (sort keys(dep)) {
X if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
X print $extra,$key,"\n";
X $extra = '';
X }
X}
X
Xsub scan {
X local($makefile) = @_;
X local($MF) = $MF;
X print stderr "Analyzing $makefile.\n" if $opt_v;
X $MF++;
X open($MF,$makefile) || die "Can't open $makefile: $!";
X while (<$MF>) {
X chop;
X chop($_ = $_ . <$MF>) while s/\\$//;
X next if /^#/;
X next if /^$/;
X s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
X s/\$\((\w+)\)/$mac{$1}/eg;
X $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
X if (/^include\s+(.*)/) {
X do scan($1);
X print stderr "Continuing $makefile.\n" if $opt_v;
X next;
X }
X if (/^([^:]+):\s*(.*)/) {
X $left = $1;
X $right = $2;
X if ($right =~ /^([^;]*);(.*)/) {
X $right = $1;
X $action = $2;
X }
X else {
X $action = '';
X }
X while (<$MF>) {
X last unless /^\t/;
X chop;
X chop($_ = $_ . <$MF>) while s/\\$//;
X next if /^#/;
X last if /^$/;
X s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
X s/\$\((\w+)\)/$mac{$1}/eg;
X $action .= $_;
X }
X foreach $targ (split(' ',$left)) {
X $targ =~ s|^\./||;
X foreach $src (split(' ',$right)) {
X $src =~ s|^\./||;
X $deplist{$targ} .= ' ' . $src;
X $dep{"$targ: $src"} = 1;
X $o{$src} = 1 if $src =~ /\.o$/;
X $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
X }
X $action{$targ} .= $action;
X }
X redo if $_;
X }
X }
X close($MF);
X}
X
Xsub subst {
X local($foo,$from,$to) = @_;
X $foo = $mac{$foo};
X $from =~ s/\./[.]/;
X y/a/a/;
X $foo =~ s/\b$from\b/$to/g;
X $foo;
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 26 (of 36)"
cat /dev/null >kit26isdone
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.