Path: wuarchive!gem.mps.ohio-state.edu!apple!bbn!bbn.com!rsalz
From: rsalz@uunet.uu.net (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v20i105:  Perl, a language with features of C/sed/awk/shell/etc, Part22/24
Message-ID: <2129@papaya.bbn.com>
Date: 2 Nov 89 21:53:16 GMT
Lines: 1920
Approved: rsalz@uunet.UU.NET

Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Posting-number: Volume 20, Issue 105
Archive-name: perl3.0/part22

#! /bin/sh

# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 24 through sh.  When all 24 kits have been run, read README.

echo "This is perl 3.0 kit 22 (of 24).  If kit 22 is complete, the line"
echo '"'"End of kit 22 (of 24)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg eg/g eg/scan lib t x2p 2>/dev/null
echo Extracting lib/termcap.pl
sed >lib/termcap.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $
X;#
X;# Usage:
X;#	do 'ioctl.pl';
X;#	ioctl(TTY,$TIOCGETP,$foo);
X;#	($ispeed,$ospeed) = unpack('cc',$foo);
X;#	do 'termcap.pl';
X;#	do Tgetent('vt100');	# sets $TC{'cm'}, etc.
X;#	do Tgoto($TC{'cm'},$row,$col);
X;#	do Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
X;#
Xsub Tgetent {
X    local($TERM) = @_;
X    local($TERMCAP,$_,$entry,$loop,$field);
X
X    warn "Tgetent: no ospeed set" unless $ospeed;
X    foreach $key (keys(TC)) {
X	delete $TC{$key};
X    }
X    $TERM = $ENV{'TERM'} unless $TERM;
X    $TERMCAP = $ENV{'TERMCAP'};
X    $TERMCAP = '/etc/termcap' unless $TERMCAP;
X    if ($TERMCAP !~ m:^/:) {
X	if (index($TERMCAP,"|$TERM|") < $[) {
X	    $TERMCAP = '/etc/termcap';
X	}
X    }
X    if ($TERMCAP =~ m:^/:) {
X	$entry = '';
X	do {
X	    $loop = "
X	    open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
X	    while (<TERMCAP>) {
X		next if /^#/;
X		next if /^\t/;
X		if (/\\|$TERM[:\\|]/) {
X		    chop;
X		    while (chop eq '\\\\') {
X			\$_ .= <TERMCAP>;
X			chop;
X		    }
X		    \$_ .= ':';
X		    last;
X		}
X	    }
X	    close TERMCAP;
X	    \$entry .= \$_;
X	    ";
X	    eval $loop;
X	} while s/:tc=([^:]+):/:/, $TERM = $1;
X	$TERMCAP = $entry;
X    }
X
X    foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
X	if ($field =~ /^\w\w$/) {
X	    $TC{$field} = 1;
X	}
X	elsif ($field =~ /^(\w\w)#(.*)/) {
X	    $TC{$1} = $2 if $TC{$1} eq '';
X	}
X	elsif ($field =~ /^(\w\w)=(.*)/) {
X	    $entry = $1;
X	    $_ = $2;
X	    s/\\E/\033/g;
X	    s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
X	    s/\\n/\n/g;
X	    s/\\r/\r/g;
X	    s/\\t/\t/g;
X	    s/\\b/\b/g;
X	    s/\\f/\f/g;
X	    s/\\\^/\377/g;
X	    s/\^\?/\177/g;
X	    s/\^(.)/pack('c',$1 & 031)/eg;
X	    s/\\(.)/$1/g;
X	    s/\377/^/g;
X	    $TC{$entry} = $_ if $TC{$entry} eq '';
X	}
X    }
X    $TC{'pc'} = "\0" if $TC{'pc'} eq '';
X    $TC{'bc'} = "\b" if $TC{'bc'} eq '';
X}
X
X@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
X
Xsub Tputs {
X    local($string,$affcnt,$FH) = @_;
X    local($ms);
X    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
X	$ms = $1;
X	$ms *= $affcnt if $2;
X	$string = $3;
X	$decr = $Tputs[$ospeed];
X	if ($decr > .1) {
X	    $ms += $decr / 2;
X	    $string .= $TC{'pc'} x ($ms / $decr);
X	}
X    }
X    print $FH $string if $FH;
X    $string;
X}
X
Xsub Tgoto {
X    local($string) = shift(@_);
X    local($result) = '';
X    local($after) = '';
X    local($code,$tmp) = @_;
X    @_ = ($tmp,$code);
X    local($online) = 0;
X    while ($string =~ /^([^%]*)%(.)(.*)/) {
X	$result .= $1;
X	$code = $2;
X	$string = $3;
X	if ($code eq 'd') {
X	    $result .= sprintf("%d",shift(@_));
X	}
X	elsif ($code eq '.') {
X	    $tmp = shift(@_);
X	    if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
X		if ($online) {
X		    ++$tmp, $after .= $TC{'up'} if $TC{'up'};
X		}
X		else {
X		    ++$tmp, $after .= $TC{'bc'};
X		}
X	    }
X	    $result .= sprintf("%c",$tmp);
X	    $online = !$online;
X	}
X	elsif ($code eq '+') {
X	    $result .= sprintf("%c",shift(@_)+ord($string));
X	    $string = substr($string,1,99);
X	    $online = !$online;
X	}
X	elsif ($code eq 'r') {
X	    ($code,$tmp) = @_;
X	    @_ = ($tmp,$code);
X	    $online = !$online;
X	}
X	elsif ($code eq '>') {
X	    ($code,$tmp,$string) = unpack("CCa99",$string);
X	    if ($_[$[] > $code) {
X		$_[$[] += $tmp;
X	    }
X	}
X	elsif ($code eq '2') {
X	    $result .= sprintf("%02d",shift(@_));
X	    $online = !$online;
X	}
X	elsif ($code eq '3') {
X	    $result .= sprintf("%03d",shift(@_));
X	    $online = !$online;
X	}
X	elsif ($code eq 'i') {
X	    ($code,$tmp) = @_;
X	    @_ = ($code+1,$tmp+1);
X	}
X	else {
X	    return "OOPS";
X	}
X    }
X    $result . $string . $after;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting t/op.pat
sed >t/op.pat <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.pat,v 3.0 89/10/18 15:30:44 lwall Locked $
X
Xprint "1..43\n";
X
X$x = "abc\ndef\n";
X
Xif ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
Xif ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
X
X$* = 1;
Xif ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
X$* = 0;
X
X$_ = '123';
Xif (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
X
Xif ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
Xif ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
X
Xif ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
Xif ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
X
Xif ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
Xif ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
X
Xif ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
Xif ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
X
X$_ = 'aaabbbccc';
Xif (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
X	print "ok 13\n";
X} else {
X	print "not ok 13\n";
X}
Xif (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
X	print "ok 14\n";
X} else {
X	print "not ok 14\n";
X}
X
Xif (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
X
X$_ = 'aaabccc';
Xif (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
Xif (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
X
X$_ = 'aaaccc';
Xif (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
Xif (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
X
X$_ = 'abcdef';
Xif (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
Xif (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
X
Xif (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
X
Xif (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
X
X$* = 1;		# test 3 only tested the optimized version--this one is for real
Xif ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
X$* = 0;
X
X$XXX{123} = 123;
X$XXX{234} = 234;
X$XXX{345} = 345;
X
X@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
Xwhile ($_ = shift(XXX)) {
X    ?(.*)? && (print $1,"\n");
X    /not/ && reset;
X    /not ok 26/ && reset 'X';
X}
X
Xwhile (($key,$val) = each(XXX)) {
X    print "not ok 27\n";
X    exit;
X}
X
Xprint "ok 27\n";
X
X'cde' =~ /[^ab]*/;
X'xyz' =~ //;
Xif ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
X
X$foo = '[^ab]*';
X'cde' =~ /$foo/;
X'xyz' =~ //;
Xif ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
X
X$foo = '[^ab]*';
X'cde' =~ /$foo/;
X'xyz' =~ /$null/;
Xif ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
X
X$_ = 'abcdefghi';
X/def/;		# optimized up to cmd
Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
X
X/cde/ + 0;	# optimized only to spat
Xif ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
X
X/[d][e][f]/;	# not optimized
Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
X
X$_ = 'now is the {time for all} good men to come to.';
X/ {([^}]*)}/;
Xif ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
X
X$_ = 'xxx {3,4}  yyy   zzz';
Xprint /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
Xprint $1 eq '   ' ? "ok 36\n" : "not ok 36\n";
Xprint /( {4,})/ ? "not ok 37\n" : "ok 37\n";
Xprint /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
Xprint $1 eq '  y' ? "ok 39\n" : "not ok 39\n";
Xprint /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
Xprint $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
Xprint /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
Xprint /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
!STUFFY!FUNK!
echo Extracting x2p/Makefile.SH
sed >x2p/Makefile.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xcase $CONFIG in
X'')
X    if test ! -f config.sh; then
X	ln ../config.sh . || \
X	ln ../../config.sh . || \
X	ln ../../../config.sh . || \
X	(echo "Can't find config.sh."; exit 1)
X    fi
X    . ./config.sh
X    ;;
Xesac
Xcase "$mallocsrc" in
X'') ;;
X*) mallocsrc="../$mallocsrc";;
Xesac
Xecho "Extracting x2p/Makefile (with variable substitutions)"
Xcat >Makefile <<!GROK!THIS!
X# $Header: Makefile.SH,v 3.0 89/10/18 15:33:52 lwall Locked $
X#
X# $Log:	Makefile.SH,v $
X# Revision 3.0  89/10/18  15:33:52  lwall
X# 3.0 baseline
X# 
X# Revision 2.0.1.2  88/09/07  17:13:30  lwall
X# patch14: added redirection of stderr to /dev/null
X# 
X# Revision 2.0.1.1  88/07/11  23:13:39  root
X# patch2: now expects more shift/reduce errors
X# 
X# Revision 2.0  88/06/05  00:15:31  root
X# Baseline version 2.0.
X# 
X# 
X
XCC = $cc
Xbin = $bin
Xlib = $lib
Xmansrc = $mansrc
Xmanext = $manext
XCFLAGS = $ccflags $optimize
XLDFLAGS = $ldflags
XSMALL = $small
XLARGE = $large $split
Xmallocsrc = $mallocsrc
Xmallocobj = $mallocobj
X
Xlibs = $libnm -lm $libs
X!GROK!THIS!
X
Xcat >>Makefile <<'!NO!SUBS!'
X
Xpublic = a2p s2p
X
Xprivate = 
X
Xmanpages = a2p.man s2p.man
X
Xutil =
X
Xsh = Makefile.SH makedepend.SH
X
Xh = EXTERN.h INTERN.h config.h handy.h hash.h a2p.h str.h util.h
X
Xc = hash.c $(mallocsrc) str.c util.c walk.c
X
Xobj = hash.o $(mallocobj) str.o util.o walk.o
X
Xlintflags = -phbvxac
X
Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
X
X# grrr
XSHELL = /bin/sh
X
X.c.o:
X	$(CC) -c $(CFLAGS) $(LARGE) $*.c
X
Xall: $(public) $(private) $(util)
X	touch all
X
Xa2p: $(obj) a2p.o
X	$(CC) $(LARGE) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
X
Xa2p.c: a2p.y
X	@ echo Expect 208 shift/reduce conflicts...
X	yacc a2p.y
X	mv y.tab.c a2p.c
X
Xa2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h
X	$(CC) -c $(CFLAGS) $(LARGE) a2p.c
X
Xinstall: a2p s2p
X# won't work with csh
X	export PATH || exit 1
X	- mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null
X	- mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null
X	- if test `pwd` != $(bin); then cp $(public) $(bin); fi
X	cd $(bin); \
Xfor pub in $(public); do \
Xchmod +x `basename $$pub`; \
Xdone
X#	chmod +x makedir
X#	- ./makedir `filexp $(lib)`
X#	- \
X#if test `pwd` != `filexp $(lib)`; then \
X#cp $(private) `filexp $(lib)`; \
X#fi
X#	cd `filexp $(lib)`; \
X#for priv in $(private); do \
X#chmod +x `basename $$priv`; \
X#done
X	- if test `pwd` != $(mansrc); then \
Xfor page in $(manpages); do \
Xcp $$page $(mansrc)/`basename $$page .man`.$(manext); \
Xdone; \
Xfi
X
Xclean:
X	rm -f *.o
X
Xrealclean:
X	rm -f a2p *.orig */*.orig *.o core $(addedbyconf)
X
X# The following lint has practically everything turned on.  Unfortunately,
X# you have to wade through a lot of mumbo jumbo that can't be suppressed.
X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
X# for that spot.
X
Xlint:
X	lint $(lintflags) $(defs) $(c) > a2p.fuzz
X
Xdepend: ../makedepend
X	../makedepend
X
Xclist:
X	echo $(c) | tr ' ' '\012' >.clist
X
Xhlist:
X	echo $(h) | tr ' ' '\012' >.hlist
X
Xshlist:
X	echo $(sh) | tr ' ' '\012' >.shlist
X
X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
X$(obj):
X	@ echo "You haven't done a "'"make depend" yet!'; exit 1
Xmakedepend: makedepend.SH
X	/bin/sh makedepend.SH
X!NO!SUBS!
X$eunicefix Makefile
Xcase `pwd` in
X*SH)
X    $rm -f ../Makefile
X    ln Makefile ../Makefile
X    ;;
Xesac
!STUFFY!FUNK!
echo Extracting t/op.array
sed >t/op.array <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.array,v 3.0 89/10/18 15:26:55 lwall Locked $
X
Xprint "1..30\n";
X
X@ary = (1,2,3,4,5);
Xif (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$tmp = $ary[$#ary]; --$#ary;
Xif ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
Xif ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
Xif (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
X
X$[ = 1;
X@ary = (1,2,3,4,5);
Xif (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
X
X$tmp = $ary[$#ary]; --$#ary;
Xif ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
Xif ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
Xif (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
X
Xif ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
X
X$#ary += 1;	# see if we can recover element 5
Xif ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
Xif ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";}
X
X$[ = 0;
X@foo = ();
X$r = join(',', $#foo, @foo);
Xif ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
X$foo[0] = '0';
X$r = join(',', $#foo, @foo);
Xif ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
X$foo[2] = '2';
X$r = join(',', $#foo, @foo);
Xif ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
X@bar = ();
X$bar[0] = '0';
X$bar[1] = '1';
X$r = join(',', $#bar, @bar);
Xif ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
X@bar = ();
X$r = join(',', $#bar, @bar);
Xif ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
X$bar[0] = '0';
X$r = join(',', $#bar, @bar);
Xif ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
X$bar[2] = '2';
X$r = join(',', $#bar, @bar);
Xif ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
Xreset 'b';
X@bar = ();
X$bar[0] = '0';
X$r = join(',', $#bar, @bar);
Xif ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
X$bar[2] = '2';
X$r = join(',', $#bar, @bar);
Xif ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
X
X$foo = 'now is the time';
Xif (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
X    if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
X	print "ok 21\n";
X    }
X    else {
X	print "not ok 21\n";
X    }
X}
Xelse {
X    print "not ok 21\n";
X}
X
X$foo = 'lskjdf';
Xif ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
X    print "not ok 22 $cnt $F1:$F2:$Etc\n";
X}
Xelse {
X    print "ok 22\n";
X}
X
X%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
X%bar = %foo;
Xprint $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
X%bar = ();
Xprint $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
X(%bar,$a,$b) = (%foo,'how','now');
Xprint $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
Xprint $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
X@bar{keys %foo} = values %foo;
Xprint $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
Xprint $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
X
X@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
Xprint join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
X
X@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
Xprint join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
!STUFFY!FUNK!
echo Extracting eg/g/gsh
sed >eg/g/gsh <<'!STUFFY!FUNK!' -e 's/X//'
X#!/bin/perl
X
X# $Header: gsh,v 3.0 89/10/18 15:14:36 lwall Locked $
X
X# Do rsh globally--see man page
X
X$SIG{'QUIT'} = 'quit';			# install signal handler for SIGQUIT
X
Xsub getswitches {
X    while ($ARGV[0] =~ /^-/) {		# parse switches
X	$ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift,next);
X	$ARGV[0] =~ /^-s/ && ($silent++,shift,next);
X	$ARGV[0] =~ /^-d/ && ($dodist++,shift,next);
X	$ARGV[0] =~ /^-n/ && ($n=' -n',shift,next);
X	$ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift,shift,next);
X	last;
X    }
X}
X
Xdo getswitches();			# get any switches before class
X$systype = shift;			# get name representing set of hosts
Xdo getswitches();			# same switches allowed after class
X
Xif ($dodist) {				# distribute input over all rshes?
X    `cat >/tmp/gsh$$`;			#  get input into a handy place
X    $dist = " </tmp/gsh$$";		#  each rsh takes input from there
X}
X
X$cmd = join(' ',@ARGV);			# remaining args constitute the command
X$cmd =~ s/'/'"'"'/g;			# quote any embedded single quotes
X
X$one_of_these = ":$systype:";		# prepare to expand "macros"
X$one_of_these =~ s/\+/:/g;		# we hope to end up with list of
X$one_of_these =~ s/-/:-/g;		#  colon separated attributes
X
X@ARGV = ();
Xpush(@ARGV,'.grem') if -f '.grem';
Xpush(@ARGV,'.ghosts') if -f '.ghosts';
Xpush(@ARGV,'/etc/ghosts');
X
X$remainder = '';
X
Xline: while (<>) {		# for each line of ghosts
X
X    s/[ \t]*\n//;			# trim trailing whitespace
X    if (!$_ || /^#/) {			# skip blank line or comment
X	next line;
X    }
X
X    if (/^(\w+)=(.+)/) {		# a macro line?
X	$name = $1; $repl = $2;
X	$repl =~ s/\+/:/g;
X	$repl =~ s/-/:-/g;
X	$one_of_these =~ s/:$name:/:$repl:/;	# do expansion in "wanted" list
X	$repl =~ s/:/:-/g;
X	$one_of_these =~ s/:-$name:/:-$repl:/;
X	next line;
X    }
X
X    # we have a normal line
X
X    @attr = split(' ');			# a list of attributes to match against
X					#   which we put into an array
X    $host = $attr[0];			# the first attribute is the host name
X    if ($showhost) {
X	$showhost = "$host:\t";
X    }
X
X    $wanted = 0;
X    foreach $attr (@attr) {		# iterate over attribute array
X	$wanted++ if index($one_of_these,":$attr:") >= 0;
X	$wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
X    }
X    if ($wanted > 0) {
X	print "rsh $host$l$n '$cmd'\n" unless $silent;
X	$SIG{'INT'} = 'DEFAULT';
X	if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) {	# start an rsh
X	    $SIG{'INT'} = 'cont';
X	    for ($iter=0; <pipe>; $iter++) {
X		unless ($iter) {
X		    $remainder .= "$host+"
X			if /Connection timed out|Permission denied/;
X		}
X		print $showhost,$_;
X	    }
X	    close(pipe);
X	} else {
X	    print "(Can't execute rsh: $!)\n";
X	    $SIG{'INT'} = 'cont';
X	}
X    }
X}
X
Xunlink "/tmp/gsh$$" if $dodist;
X
Xif ($remainder) {
X    chop($remainder);
X    open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n");
X    print grem 'rem=', $remainder, "\n";
X    close(grem);
X    print 'rem=', $remainder, "\n";
X}
X
X# here are a couple of subroutines that serve as signal handlers
X
Xsub cont {
X    print "\rContinuing...\n";
X    $remainder .= "$host+";
X}
X
Xsub quit {
X    $| = 1;
X    print "\r";
X    $SIG{'INT'} = '';
X    kill 2, $$;
X}
!STUFFY!FUNK!
echo Extracting t/re_tests
sed >t/re_tests <<'!STUFFY!FUNK!' -e 's/X//'
Xabc	abc	y	$&	abc
Xabc	xbc	n	-	-
Xabc	axc	n	-	-
Xabc	abx	n	-	-
Xabc	xabcy	y	$&	abc
Xabc	ababc	y	$&	abc
Xab*c	abc	y	$&	abc
Xab*bc	abc	y	$&	abc
Xab*bc	abbc	y	$&	abbc
Xab*bc	abbbbc	y	$&	abbbbc
Xab{0,}bc	abbbbc	y	$&	abbbbc
Xab+bc	abbc	y	$&	abbc
Xab+bc	abc	n	-	-
Xab+bc	abq	n	-	-
Xab{1,}bc	abq	n	-	-
Xab+bc	abbbbc	y	$&	abbbbc
Xab{1,}bc	abbbbc	y	$&	abbbbc
Xab{1,3}bc	abbbbc	y	$&	abbbbc
Xab{3,4}bc	abbbbc	y	$&	abbbbc
Xab{4,5}bc	abbbbc	n	-	-
Xab?bc	abbc	y	$&	abbc
Xab?bc	abc	y	$&	abc
Xab{0,1}bc	abc	y	$&	abc
Xab?bc	abbbbc	n	-	-
Xab?c	abc	y	$&	abc
Xab{0,1}c	abc	y	$&	abc
X^abc$	abc	y	$&	abc
X^abc$	abcc	n	-	-
X^abc	abcc	y	$&	abc
X^abc$	aabc	n	-	-
Xabc$	aabc	y	$&	abc
X^	abc	y	$&	
X$	abc	y	$&	
Xa.c	abc	y	$&	abc
Xa.c	axc	y	$&	axc
Xa.*c	axyzc	y	$&	axyzc
Xa.*c	axyzd	n	-	-
Xa[bc]d	abc	n	-	-
Xa[bc]d	abd	y	$&	abd
Xa[b-d]e	abd	n	-	-
Xa[b-d]e	ace	y	$&	ace
Xa[b-d]	aac	y	$&	ac
Xa[-b]	a-	y	$&	a-
Xa[b-]	a-	y	$&	a-
Xa[b-a]	-	c	-	-
Xa[]b	-	c	-	-
Xa[	-	c	-	-
Xa]	a]	y	$&	a]
Xa[]]b	a]b	y	$&	a]b
Xa[^bc]d	aed	y	$&	aed
Xa[^bc]d	abd	n	-	-
Xa[^-b]c	adc	y	$&	adc
Xa[^-b]c	a-c	n	-	-
Xa[^]b]c	a]c	n	-	-
Xa[^]b]c	adc	y	$&	adc
Xab|cd	abc	y	$&	ab
Xab|cd	abcd	y	$&	ab
X()ef	def	y	$&-$1	ef-
X()*	-	c	-	-
X*a	-	c	-	-
X^*	-	c	-	-
X$*	-	c	-	-
X(*)b	-	c	-	-
X$b	b	n	-	-
Xa\	-	c	-	-
Xa\(b	a(b	y	$&-$1	a(b-
Xa\(*b	ab	y	$&	ab
Xa\(*b	a((b	y	$&	a((b
Xa\\b	a\b	y	$&	a\b
Xabc)	-	c	-	-
X(abc	-	c	-	-
X((a))	abc	y	$&-$1-$2	a-a-a
X(a)b(c)	abc	y	$&-$1-$2	abc-a-c
Xa+b+c	aabbabc	y	$&	abc
Xa{1,}b{1,}c	aabbabc	y	$&	abc
Xa**	-	c	-	-
Xa*?	-	c	-	-
X(a*)*	-	c	-	-
X(a*)+	-	c	-	-
X(a|)*	-	c	-	-
X(a*|b)*	-	c	-	-
X(a+|b)*	ab	y	$&-$1	ab-b
X(a+|b){0,}	ab	y	$&-$1	ab-b
X(a+|b)+	ab	y	$&-$1	ab-b
X(a+|b){1,}	ab	y	$&-$1	ab-b
X(a+|b)?	ab	y	$&-$1	a-a
X(a+|b){0,1}	ab	y	$&-$1	a-a
X(^)*	-	c	-	-
X(ab|)*	-	c	-	-
X)(	-	c	-	-
X[^ab]*	cde	y	$&	cde
Xabc		n	-	-
Xa*		y	$&	
X([abc])*d	abbbcd	y	$&-$1	abbbcd-c
X([abc])*bcd	abcd	y	$&-$1	abcd-a
Xa|b|c|d|e	e	y	$&	e
X(a|b|c|d|e)f	ef	y	$&-$1	ef-e
X((a*|b))*	-	c	-	-
Xabcd*efg	abcdefg	y	$&	abcdefg
Xab*	xabyabbbz	y	$&	ab
Xab*	xayabbbz	y	$&	a
X(ab|cd)e	abcde	y	$&-$1	cde-cd
X[abhgefdc]ij	hij	y	$&	hij
X^(ab|cd)e	abcde	n	x$1y	xy
X(abc|)ef	abcdef	y	$&-$1	ef-
X(a|b)c*d	abcd	y	$&-$1	bcd-b
X(ab|ab*)bc	abc	y	$&-$1	abc-a
Xa([bc]*)c*	abc	y	$&-$1	abc-bc
Xa([bc]*)(c*d)	abcd	y	$&-$1-$2	abcd-bc-d
Xa([bc]+)(c*d)	abcd	y	$&-$1-$2	abcd-bc-d
Xa([bc]*)(c+d)	abcd	y	$&-$1-$2	abcd-b-cd
Xa[bcd]*dcdcde	adcdcde	y	$&	adcdcde
Xa[bcd]+dcdcde	adcdcde	n	-	-
X(ab|a)b*c	abc	y	$&-$1	abc-ab
X((a)(b)c)(d)	abcd	y	$1-$2-$3-$4	abc-a-b-d
X[a-zA-Z_][a-zA-Z0-9_]*	alpha	y	$&	alpha
X^a(bc+|b[eh])g|.h$	abh	y	$&-$1	bh-
X(bc+d$|ef*g.|h?i(j|k))	effgz	y	$&-$1-$2	effgz-effgz-
X(bc+d$|ef*g.|h?i(j|k))	ij	y	$&-$1-$2	ij-ij-j
X(bc+d$|ef*g.|h?i(j|k))	effg	n	-	-
X(bc+d$|ef*g.|h?i(j|k))	bcdd	n	-	-
X(bc+d$|ef*g.|h?i(j|k))	reffgz	y	$&-$1-$2	effgz-effgz-
X((((((((((a))))))))))	-	c	-	-
X(((((((((a)))))))))	a	y	$&	a
Xmultiple words of text	uh-uh	n	-	-
Xmultiple words	multiple words, yeah	y	$&	multiple words
X(.*)c(.*)	abcde	y	$&-$1-$2	abcde-ab-de
X\((.*), (.*)\)	(a, b)	y	($2, $1)	(b, a)
X[k]	ab	n	-	-
Xabcd	abcd	y	$&-\$&-\\$&	abcd-$&-\abcd
Xa(bc)d	abcd	y	$1-\$1-\\$1	bc-$1-\bc
Xa[-]?c	ac	y	$&	ac
X(abc)\1	abcabc	y	$1	abc
X([a-c]*)\1	abcabc	y	$1	abc
!STUFFY!FUNK!
echo Extracting t/io.fs
sed >t/io.fs <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: io.fs,v 3.0 89/10/18 15:26:20 lwall Locked $
X
Xprint "1..22\n";
X
X$wd = `pwd`;
Xchop($wd);
X
X`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
Xchdir './tmp';
X`/bin/rm -rf a b c x`;
X
Xumask(022);
X
Xif (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
Xopen(fh,'>x') || die "Can't create x";
Xclose(fh);
Xopen(fh,'>a') || die "Can't create a";
Xclose(fh);
X
Xif (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";}
X
Xif (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";}
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('c');
X
Xif ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";}
Xif (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";}
X
Xif ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('c');
Xif (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";}
X
Xif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";}
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('c');
Xif (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('x');
Xif (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";}
X
Xif ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('b');
Xif ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('x');
Xif ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";}
X
Xif (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('a');
Xif ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
X$foo = (utime 500000000,500000001,'b');
Xif ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('b');
Xif ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
Xif ($atime == 500000000 && $mtime == 500000001)
X    {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";}
X
Xif ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X    $blksize,$blocks) = stat('b');
Xif ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
Xunlink 'c';
X
Xchdir $wd || die "Can't cd back to $wd";
X
Xunlink 'c';
Xif (`ls -l perl 2>/dev/null` =~ /^l.*->/) {  # we have symbolic links
X    if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
X    $foo = `grep perl c`;
X    if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
X}
Xelse {
X    print "ok 21\nok 22\n";
X}
!STUFFY!FUNK!
echo Extracting t/comp.cmdopt
sed >t/comp.cmdopt <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: comp.cmdopt,v 3.0 89/10/18 15:25:13 lwall Locked $
X
Xprint "1..40\n";
X
X# test the optimization of constants
X
Xif (1) { print "ok 1\n";} else { print "not ok 1\n";}
Xunless (0) { print "ok 2\n";} else { print "not ok 2\n";}
X
Xif (0) { print "not ok 3\n";} else { print "ok 3\n";}
Xunless (1) { print "not ok 4\n";} else { print "ok 4\n";}
X
Xunless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
Xif (!0) { print "ok 6\n";} else { print "not ok 6\n";}
X
Xunless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
Xif (!1) { print "not ok 8\n";} else { print "ok 8\n";}
X
X$x = 1;
Xif (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
Xif (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
X$x = '';
Xif (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
Xif (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
X
X$x = 1;
Xif (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
Xif (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
X$x = '';
Xif (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
Xif (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
X
X
X# test the optimization of registers
X
X$x = 1;
Xif ($x) { print "ok 17\n";} else { print "not ok 17\n";}
Xunless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
X
X$x = '';
Xif ($x) { print "not ok 19\n";} else { print "ok 19\n";}
Xunless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
X
X# test optimization of string operations
X
X$a = 'a';
Xif ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
Xif ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
X
Xif ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
Xif ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
X# test interaction of logicals and other operations
X
X$a = 'a';
X$x = 1;
Xif ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
Xif ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
X$x = '';
Xif ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
Xif ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
X
X$x = 1;
Xif ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
Xif ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
X$x = '';
Xif ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
Xif ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
X
X$x = 1;
Xif ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
Xif ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
X$x = '';
Xif ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
X    if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
X
X$x = 1;
Xif ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
Xif ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
X$x = '';
Xif ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
Xif ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
!STUFFY!FUNK!
echo Extracting 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 Extracting handy.h
sed >handy.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: handy.h,v 3.0 89/10/18 15:18:24 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:	handy.h,v $
X * Revision 3.0  89/10/18  15:18:24  lwall
X * 3.0 baseline
X * 
X */
X
X#ifdef NULL
X#undef NULL
X#endif
X#ifndef I286
X#  define NULL 0
X#else
X#  define NULL 0L
X#endif
X#define Null(type) ((type)NULL)
X#define Nullch Null(char*)
X#define Nullfp Null(FILE*)
X
X#ifdef UTS
X#define bool int
X#else
X#define bool char
X#endif
X#define TRUE (1)
X#define FALSE (0)
X
X#define Ctl(ch) (ch & 037)
X
X#define strNE(s1,s2) (strcmp(s1,s2))
X#define strEQ(s1,s2) (!strcmp(s1,s2))
X#define strLT(s1,s2) (strcmp(s1,s2) < 0)
X#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
X#define strGT(s1,s2) (strcmp(s1,s2) > 0)
X#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
X#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
X#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
X
X#define MEM_SIZE unsigned int
X
X/* Line numbers are unsigned, 16 bits. */
Xtypedef unsigned short line_t;
X#ifdef lint
X#define NOLINE ((line_t)0)
X#else
X#define NOLINE ((line_t) 65535)
X#endif
X
X#ifndef lint
X#ifndef LEAKTEST
Xchar *safemalloc();
Xchar *saferealloc();
Xvoid safefree();
X#define New(x,v,n,t)  (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
X#define Newc(x,v,n,t,c)  (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
X#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \
X    bzero((char*)(v), (n) * sizeof(t))
X#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Safefree(d) safefree((char*)d)
X#define Str_new(x,len) str_new(len)
X#else /* LEAKTEST */
Xchar *safexmalloc();
Xchar *safexrealloc();
Xvoid safexfree();
X#define New(x,v,n,t)  (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
X#define Newc(x,v,n,t,c)  (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
X#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \
X    bzero((char*)(v), (n) * sizeof(t))
X#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Safefree(d) safexfree((char*)d)
X#define Str_new(x,len) str_new(x,len)
X#define MAXXCOUNT 1200
Xlong xcount[MAXXCOUNT];
Xlong lastxcount[MAXXCOUNT];
X#endif /* LEAKTEST */
X#define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t))
X#define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t))
X#else /* lint */
X#define New(x,v,n,s) (v = Null(s *))
X#define Newc(x,v,n,s,c) (v = Null(s *))
X#define Newz(x,v,n,s) (v = Null(s *))
X#define Renew(v,n,s) (v = Null(s *))
X#define Copy(s,d,n,t)
X#define Zero(d,n,t)
X#define Safefree(d) d = d
X#endif /* lint */
!STUFFY!FUNK!
echo Extracting eg/g/gcp
sed >eg/g/gcp <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: gcp,v 3.0 89/10/18 15:13:59 lwall Locked $
X
X# Here is a script to do global rcps.  See man page.
X
X$#ARGV >= 1 || die "Not enough arguments.\n";
X
Xif ($ARGV[0] eq '-r') {
X    $rcp = 'rcp -r';
X    shift;
X} else {
X    $rcp = 'rcp';
X}
X$args = $rcp;
X$dest = $ARGV[$#ARGV];
X
X$SIG{'QUIT'} = 'CLEANUP';
X$SIG{'INT'} = 'CONT';
X
Xwhile ($arg = shift) {
X    if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
X	if ($systype && $systype ne $1) {
X	    die "Can't mix system type specifers ($systype vs $1).\n";
X	}
X	$#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
X	$systype = $1;
X	$args .= " $arg";
X    } else {
X	if ($#ARGV >= 0) {
X	    if ($arg =~ /^[\/~]/) {
X		$arg =~ /^(.*)\// && ($dir = $1);
X	    } else {
X		if (!$pwd) {
X		    chop($pwd = `pwd`);
X		}
X		$dir = $pwd;
X	    }
X	}
X	if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
X	    $args .= " $dest$olddir; $rcp";
X	}
X	$olddir = $dir;
X	$args .= " $arg";
X    }
X}
X
Xdie "No system type specified.\n" unless $systype;
X
X$args =~ s/:$/:$olddir/;
X
Xchop($thishost = `hostname`);
X
X$one_of_these = ":$systype:";
Xif ($systype =~ s/\+/[+]/g) {
X    $one_of_these =~ s/\+/:/g;
X}
X$one_of_these =~ s/-/:-/g;
X
X@ARGV = ();
Xpush(@ARGV,'.grem') if -f '.grem';
Xpush(@ARGV,'.ghosts') if -f '.ghosts';
Xpush(@ARGV,'/etc/ghosts');
X
X$remainder = '';
X
Xline: while (<>) {
X    s/[ \t]*\n//;
X    if (!$_ || /^#/) {
X	next line;
X    }
X    if (/^([a-zA-Z_0-9]+)=(.+)/) {
X	$name = $1; $repl = $2;
X	$repl =~ s/\+/:/g;
X	$repl =~ s/-/:-/g;
X	$one_of_these =~ s/:$name:/:$repl:/;
X	$repl =~ s/:/:-/g;
X	$one_of_these =~ s/:-$name:/:-$repl:/g;
X	next line;
X    }
X    @gh = split(' ');
X    $host = $gh[0];
X  next line if $host eq $thishost;	# should handle aliases too
X    $wanted = 0;
X    foreach $class (@gh) {
X	$wanted++ if index($one_of_these,":$class:") >= 0;
X	$wanted = -9999 if index($one_of_these,":-$class:") >= 0;
X    }
X    if ($wanted > 0) {
X	($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
X	print "$cmd\n";
X	$result = `$cmd 2>&1`;
X	$remainder .= "$host+" if
X	    $result =~ /Connection timed out|Permission denied/;
X	print $result;
X    }
X}
X
Xif ($remainder) {
X    chop($remainder);
X    open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n");
X    print grem 'rem=', $remainder, "\n";
X    close(grem);
X    print 'rem=', $remainder, "\n";
X}
X
Xsub CLEANUP {
X    exit;
X}
X
Xsub CONT {
X    print "Continuing...\n";	# Just ignore the signal that kills rcp
X    $remainder .= "$host+";
X}
!STUFFY!FUNK!
echo Extracting t/cmd.while
sed >t/cmd.while <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.while,v 3.0 89/10/18 15:25:07 lwall Locked $
X
Xprint "1..10\n";
X
Xopen (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp.";
Xprint tmp "tvi925\n";
Xprint tmp "tvi920\n";
Xprint tmp "vt100\n";
Xprint tmp "Amiga\n";
Xprint tmp "paper\n";
Xclose tmp;
X
X# test "last" command
X
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xwhile (<fh>) {
X    last if /vt100/;
X}
Xif (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";}
X
X# test "next" command
X
X$bad = '';
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xwhile (<fh>) {
X    next if /vt100/;
X    $bad = 1 if /vt100/;
X}
Xif (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";}
X
X# test "redo" command
X
X$bad = '';
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xwhile (<fh>) {
X    if (s/vt100/VT100/g) {
X	s/VT100/Vt100/g;
X	redo;
X    }
X    $bad = 1 if /vt100/;
X    $bad = 1 if /VT100/;
X}
Xif (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";}
X
X# now do the same with a label and a continue block
X
X# test "last" command
X
X$badcont = '';
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xline: while (<fh>) {
X    if (/vt100/) {last line;}
X} continue {
X    $badcont = 1 if /vt100/;
X}
Xif (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";}
Xif (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";}
X
X# test "next" command
X
X$bad = '';
X$badcont = 1;
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xentry: while (<fh>) {
X    next entry if /vt100/;
X    $bad = 1 if /vt100/;
X} continue {
X    $badcont = '' if /vt100/;
X}
Xif (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";}
Xif (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";}
X
X# test "redo" command
X
X$bad = '';
X$badcont = '';
Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
Xloop: while (<fh>) {
X    if (s/vt100/VT100/g) {
X	s/VT100/Vt100/g;
X	redo loop;
X    }
X    $bad = 1 if /vt100/;
X    $bad = 1 if /VT100/;
X} continue {
X    $badcont = 1 if /vt100/;
X}
Xif (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";}
Xif (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";}
X
X`/bin/rm -f Cmd.while.tmp`;
X
X#$x = 0;
X#while (1) {
X#    if ($x > 1) {last;}
X#    next;
X#} continue {
X#    if ($x++ > 10) {last;}
X#    next;
X#}
X#
X#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";}
X
X$i = 9;
X{
X    $i++;
X}
Xprint "ok $i\n";
!STUFFY!FUNK!
echo Extracting eg/scan/scan_suid
sed >eg/scan/scan_suid <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_suid,v 3.0 89/10/18 15:15:57 lwall Locked $
X
X# Look for new setuid root files.
X
Xchdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n";
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X   $blksize,$blocks) = stat('oldsuid');
Xif ($nlink) {
X    $lasttime = $mtime;
X    $tmp = $ctime - $atime;
X    if ($tmp <= 0 || $tmp >= 10) {
X	print "WARNING: somebody has read oldsuid!\n";
X    }
X    $tmp = $ctime - $mtime;
X    if ($tmp <= 0 || $tmp >= 10) {
X	print "WARNING: somebody has modified oldsuid!!!\n";
X    }
X} else {
X    $lasttime = time - 60 * 60 * 24;	# one day ago
X}
X$thistime = time;
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
Xopen(Find, 'find / -perm -04000 -print |') ||
X	die "scan_find: can't run find";
X#else
Xopen(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
X	die "scan_find: can't run find";
X#endif
X
Xopen(suid, '>newsuid.tmp');
X
Xwhile (<Find>) {
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
X    $x = `/bin/ls -il $_`;
X    $_ = $x;
X    s/^ *//;
X    ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
X      = split;
X#else
X    s/^ *//;
X    ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
X      = split;
X#endif
X
X    if ($perm =~ /[sS]/ && $owner eq 'root') {
X	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X	   $blksize,$blocks) = stat($name);
X	$foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
X		$perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
X	print suid $foo;
X	if ($ctime > $lasttime) {
X	    if ($ctime > $thistime) {
X		print "Future file: $foo";
X	    }
X	    else {
X		$ct .= $foo;
X	    }
X	}
X    }
X}
Xclose(suid);
X
Xprint `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
X$foo = `/bin/diff oldsuid newsuid 2>&1`;
Xprint "Differences in suid info:\n",$foo if $foo;
Xprint `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
Xprint `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
Xprint `rm -f newsuid.tmp 2>&1`;
X
X@ct = split(/\n/,$ct);
X$ct = '';
X$* = 1;
Xwhile ($#ct >= 0) {
X    $tmp = shift(@ct);
X    unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
X}
X
Xprint "Inode changed since last time:\n",$ct if $ct;
X
!STUFFY!FUNK!
echo Extracting x2p/s2p.man
sed >x2p/s2p.man <<'!STUFFY!FUNK!' -e 's/X//'
X.rn '' }`
X''' $Header: s2p.man,v 3.0 89/10/18 15:35:09 lwall Locked $
X''' 
X''' $Log:	s2p.man,v $
X''' Revision 3.0  89/10/18  15:35:09  lwall
X''' 3.0 baseline
X''' 
X''' Revision 2.0  88/06/05  00:15:59  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 S2P 1 NEW
X.SH NAME
Xs2p - Sed to Perl translator
X.SH SYNOPSIS
X.B s2p [options] filename
X.SH DESCRIPTION
X.I S2p
Xtakes a sed 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 \-n
Xspecifies that this sed script was always invoked with a sed -n.
XOtherwise a switch parser is prepended to the front of the script.
X.TP 5
X.B \-p
Xspecifies that this sed script was never invoked with a sed -n.
XOtherwise a switch parser is prepended to the front of the script.
X.Sh "Considerations"
XThe perl script produced looks very sed-ish, and there may very well be
Xbetter ways to express what you want to do in perl.
XFor instance, s2p does not make any use of the split operator, but you might
Xwant to.
X.PP
XThe perl script you end up with may be either faster or slower than the original
Xsed script.
XIf you're only interested in speed you'll just have to try it both ways.
XOf course, if you want to do something sed doesn't do, you have no choice.
X.SH ENVIRONMENT
XS2p 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
Xa2p	awk to perl translator
X.SH DIAGNOSTICS
X.SH BUGS
X.rn }` ''
!STUFFY!FUNK!
echo Extracting t/cmd.subval
sed >t/cmd.subval <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.subval,v 3.0 89/10/18 15:24:52 lwall Locked $
X
Xsub foo1 {
X    'true1';
X    if ($_[0]) { 'true2'; }
X}
X
Xsub foo2 {
X    'true1';
X    if ($_[0]) { return 'true2'; } else { return 'true3'; }
X    'true0';
X}
X
Xsub foo3 {
X    'true1';
X    unless ($_[0]) { 'true2'; }
X}
X
Xsub foo4 {
X    'true1';
X    unless ($_[0]) { 'true2'; } else { 'true3'; }
X}
X
Xsub foo5 {
X    'true1';
X    'true2' if $_[0];
X}
X
Xsub foo6 {
X    'true1';
X    'true2' unless $_[0];
X}
X
Xprint "1..26\n";
X
Xif (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
Xif (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
Xif (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
Xif (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
X
Xif (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
Xif (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
Xif (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
Xif (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
X
Xif (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
Xif (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
Xif (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
Xif (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
X
X# Now test to see that recursion works using a Fibonacci number generator
X
Xsub fib {
X    local($arg) = @_;
X    local($foo);
X    $level++;
X    if ($arg <= 2) {
X	$foo = 1;
X    }
X    else {
X	$foo = do fib($arg-1) + do fib($arg-2);
X    }
X    $level--;
X    $foo;
X}
X
X@good = (0,1,1,2,3,5,8,13,21,34,55,89);
X
Xfor ($i = 1; $i <= 10; $i++) {
X    $foo = $i + 12;
X    if (do fib($i) == $good[$i]) {
X	print "ok $foo\n";
X    }
X    else {
X	print "not ok $foo\n";
X    }
X}
X
Xsub ary1 {
X    (1,2,3);
X}
X
Xprint &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
X
Xprint join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
X
Xsub ary2 {
X    do {
X	return (1,2,3);
X	(3,2,1);
X    };
X    0;
X}
X
Xprint &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
X
X$x = join(':',&ary2);
Xprint $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
X
!STUFFY!FUNK!
echo Extracting t/op.dbm
sed >t/op.dbm <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $
X
Xif (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') {
X    print "1..0\n";
X    exit;
X}
X
Xprint "1..9\n";
X
Xunlink 'Op.dbmx.dir', 'Op.dbmx.pag';
Xumask(0);
Xprint (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X   $blksize,$blocks) = stat('Op.dbmx.pag');
Xprint (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
Xwhile (($key,$value) = each(h)) {
X    $i++;
X}
Xprint (!$i ? "ok 3\n" : "not ok 3\n");
X
X$h{'goner1'} = 'snork';
X
X$h{'abc'} = 'ABC';
X$h{'def'} = 'DEF';
X$h{'jkl','mno'} = "JKL\034MNO";
X$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
X$h{'a'} = 'A';
X$h{'b'} = 'B';
X$h{'c'} = 'C';
X$h{'d'} = 'D';
X$h{'e'} = 'E';
X$h{'f'} = 'F';
X$h{'g'} = 'G';
X$h{'h'} = 'H';
X$h{'i'} = 'I';
X
X$h{'goner2'} = 'snork';
Xdelete $h{'goner2'};
X
Xdbmclose(h);
Xprint (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n");
X
X$h{'j'} = 'J';
X$h{'k'} = 'K';
X$h{'l'} = 'L';
X$h{'m'} = 'M';
X$h{'n'} = 'N';
X$h{'o'} = 'O';
X$h{'p'} = 'P';
X$h{'q'} = 'Q';
X$h{'r'} = 'R';
X$h{'s'} = 'S';
X$h{'t'} = 'T';
X$h{'u'} = 'U';
X$h{'v'} = 'V';
X$h{'w'} = 'W';
X$h{'x'} = 'X';
X$h{'y'} = 'Y';
X$h{'z'} = 'Z';
X
X$h{'goner3'} = 'snork';
X
Xdelete $h{'goner1'};
Xdelete $h{'goner3'};
X
X@keys = keys(%h);
X@values = values(%h);
X
Xif ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
X
Xwhile (($key,$value) = each(h)) {
X    if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
X	$key =~ y/a-z/A-Z/;
X	$i++ if $key eq $value;
X    }
X}
X
Xif ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
X
X@keys = ('blurfl', keys(h), 'dyick');
Xif ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
X
X# check cache overflow and numeric keys and contents
X$ok = 1;
Xfor ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
Xfor ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
Xprint ($ok ? "ok 8\n" : "not ok 8\n");
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X   $blksize,$blocks) = stat('Op.dbmx.pag');
Xprint ($size > 0 ? "ok 9\n" : "not ok 9\n");
X
Xunlink 'Op.dbmx.dir', 'Op.dbmx.pag';
!STUFFY!FUNK!
echo Extracting eg/g/ghosts
sed >eg/g/ghosts <<'!STUFFY!FUNK!' -e 's/X//'
X# This first section gives alternate sets defined in terms of the sets given
X# by the second section.  The order is important--all references must be
X# forward references.
X
XNnd=sun-nd
Xall=sun+mc+vax
Xbaseline=sun+mc
Xsun=sun2+sun3
Xvax=750+8600
Xpep=manny+moe+jack
X
X# This second section defines the basic sets.  Each host should have a line
X# that specifies which sets it is a member of.  Extra sets should be separated
X# by white space.  (The first section isn't strictly necessary, since all sets
X# could be defined in the second section, but then it wouldn't be so readable.)
X
Xbasvax	8600	src
Xcdb0	sun3		sys
Xcdb1	sun3		sys
Xcdb2	sun3		sys
Xchief	sun3	src
Xtis0	sun3
Xmanny	sun3		sys
Xmoe	sun3		sys
Xjack	sun3		sys
Xdisney	sun3		sys
Xhuey	sun3		nd
Xdewey	sun3		nd
Xlouie	sun3		nd
Xbizet	sun2	src	sys
Xgif0	mc	src
Xmc0	mc
Xdtv0	mc
!STUFFY!FUNK!
echo ""
echo "End of kit 22 (of 24)"
cat /dev/null >kit22isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24; do
    if test -f kit${iskit}isdone; then
	run="$run $iskit"
    else
	todo="$todo $iskit"
    fi
done
case $todo in
    '')
	echo "You have run all your kits.  Please read README and then type Configure."
	chmod 755 Configure
	;;
    *)  echo "You have run$run."
	echo "You still need to run$todo."
	;;
esac
: Someone might mail this, so...
exit

-- 
Please send comp.sources.unix-related mail to rsalz@uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.