perl 3.0 beta kit [21/23]
Larry Wall
lwall at jato.Jpl.Nasa.Gov
Mon Sep 4 05:00:18 AEST 1989
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 23 through sh. When all 23 kits have been run, read README.
echo "This is perl 3.0 kit 21 (of 23). If kit 21 is complete, the line"
echo '"'"End of kit 21 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg/g eg/scan eg/van eg lib t x2p 2>/dev/null
echo Extracting t/io.fs
sed >t/io.fs <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: io.fs,v 2.0.1.1 88/07/15 01:35:39 root Exp $
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 2.0 88/06/05 00:12:34 root Exp $
X
Xprint "1..40\n";
X
X# test the optimization of constants
X
Xif (1) { print "ok 1\n";} else { print "not ok 1\n";}
Xunless (0) { print "ok 2\n";} else { print "not ok 2\n";}
X
Xif (0) { print "not ok 3\n";} else { print "ok 3\n";}
Xunless (1) { print "not ok 4\n";} else { print "ok 4\n";}
X
Xunless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
Xif (!0) { print "ok 6\n";} else { print "not ok 6\n";}
X
Xunless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
Xif (!1) { print "not ok 8\n";} else { print "ok 8\n";}
X
X$x = 1;
Xif (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
Xif (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
X$x = '';
Xif (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
Xif (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
X
X$x = 1;
Xif (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
Xif (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
X$x = '';
Xif (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
Xif (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
X
X
X# test the optimization of registers
X
X$x = 1;
Xif ($x) { print "ok 17\n";} else { print "not ok 17\n";}
Xunless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
X
X$x = '';
Xif ($x) { print "not ok 19\n";} else { print "ok 19\n";}
Xunless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
X
X# test optimization of string operations
X
X$a = 'a';
Xif ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
Xif ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
X
Xif ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
Xif ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
X# test interaction of logicals and other operations
X
X$a = 'a';
X$x = 1;
Xif ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
Xif ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
X$x = '';
Xif ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
Xif ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
X
X$x = 1;
Xif ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
Xif ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
X$x = '';
Xif ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
Xif ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
X
X$x = 1;
Xif ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
Xif ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
X$x = '';
Xif ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
X if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
X
X$x = 1;
Xif ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
Xif ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
X$x = '';
Xif ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
Xif ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
!STUFFY!FUNK!
echo Extracting 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 t/op.auto
sed >t/op.auto <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.auto,v 2.0 88/06/05 00:13:19 root Exp $
X
Xprint "1..34\n";
X
X$x = 10000;
Xif (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
Xif (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";}
Xif (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";}
Xif (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";}
Xif (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";}
Xif (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";}
Xif (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";}
Xif (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";}
Xif (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";}
Xif ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";}
X
X$x[0] = 10000;
Xif (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";}
Xif (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";}
Xif (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";}
Xif (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";}
Xif (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";}
Xif (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";}
Xif (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";}
Xif (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";}
Xif (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";}
Xif ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";}
X
X$x{0} = 10000;
Xif (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";}
Xif (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";}
Xif (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";}
Xif (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";}
Xif (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";}
Xif (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";}
Xif (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";}
Xif (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
Xif (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
Xif ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
X
X# test magical autoincrement
X
Xif (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
Xif (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
Xif (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
Xif (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
!STUFFY!FUNK!
echo Extracting t/op.list
sed >t/op.list <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.list,v 2.0.1.2 88/08/03 22:45:06 root Exp $
X
Xprint "1..27\n";
X
X at foo = (1, 2, 3, 4);
Xif ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
X
X$_ = join(':', at foo);
Xif ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
X
X($a,$b,$c,$d) = (1,2,3,4);
Xif ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";}
X
X($c,$b,$a) = split(/ /,"111 222 333");
Xif ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
X
X($a,$b,$c) = ($c,$b,$a);
Xif ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";}
X
X($a, $b) = ($b, $a);
Xif ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
X
X($a, $b[1], $c{2}, $d) = (1, 2, 3, 4);
Xif ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";}
Xif ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";}
Xif ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";}
Xif ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";}
X
X at foo = (1,2,3,4,5,6,7,8);
X($a, $b, $c, $d) = @foo;
Xprint "#11 $a;$b;$c;$d eq 1;2;3;4\n";
Xif ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
X
X at foo = (1);
Xif (join(':', at foo) eq '1') {print "ok 12\n";} else {print "not ok 12\n";}
X
X at foo = ();
X at foo = 1+2+3;
Xif (join(':', at foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
X
Xfor ($x = 0; $x < 3; $x++) {
X ($a, $b, $c) =
X $x == 0?
X ('ok ', 14, "\n"):
X $x == 1?
X ('ok ', 15, "\n"):
X # default
X ('ok ', 16, "\n");
X
X print $a,$b,$c;
X}
X
X at a = ($x == 12345 || (1,2,3));
Xif (join('', at a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
X
X at a = ($x == $x || (4,5,6));
Xif (join('', at a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
X
Xif (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";}
Xif (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";}
Xif (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";}
Xif (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";}
Xif (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";}
Xif (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";}
X
Xfor ($x = 0; $x < 3; $x++) {
X ($a, $b, $c) = do {
X if ($x == 0) {
X ('ok ', 25, "\n");
X }
X elsif ($x == 1) {
X ('ok ', 26, "\n");
X }
X else {
X ('ok ', 27, "\n");
X }
X };
X
X print $a,$b,$c;
X}
X
!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 2.0 88/06/05 00:17:02 root Exp $
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 at 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 2.0 88/06/05 00:12:31 root Exp $
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 2.0 88/06/05 00:17:54 root Exp $
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 at 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 t/cmd.subval
sed >t/cmd.subval <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.subval,v 2.0.1.1 88/07/11 23:08:24 root Exp $
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 at 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 x2p/s2p.man
sed >x2p/s2p.man <<'!STUFFY!FUNK!' -e 's/X//'
X.rn '' }`
X''' $Header: s2p.man,v 2.0 88/06/05 00:15:59 root Exp $
X'''
X''' $Log: s2p.man,v $
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 at 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 eg/scan/scanner
sed >eg/scan/scanner <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: scanner,v 2.0 88/06/05 00:17:42 root Exp $
X
X# This runs all the scan_* routines on all the machines in /etc/ghosts.
X# We run this every morning at about 6 am:
X
X# !/bin/sh
X# cd /usr/adm/private
X# decrypt scanner | perl >scan.out 2>&1
X# mail admin <scan.out
X
X# Note that the scan_* files should be encrypted with the key "-inquire", and
X# scanner should be encrypted somehow so that people can't find that key.
X# I leave it up to you to figure out how to unencrypt it before executing.
X
X$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
X
X$| = 1; # command buffering on stdout
X
Xprint "Subject: bizarre happenings\n\n";
X
X(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
X
Xif ($#ARGV >= 0) {
X @scanlist = @ARGV;
X} else {
X @scanlist = split(/[ \t\n]+/,`echo scan_*`);
X}
X
Xscan: while ($scan = shift(@scanlist)) {
X print "\n********** $scan **********\n";
X $showhost++;
X
X $systype = 'all';
X
X open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
X
X $one_of_these = ":$systype:";
X if ($systype =~ s/\+/[+]/g) {
X $one_of_these =~ s/\+/:/g;
X }
X
X line: while (<ghosts>) {
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 $one_of_these =~ s/:$name:/:$repl:/;
X next line;
X }
X @gh = split;
X $host = $gh[0];
X if ($showhost) { $showhost = "$host:\t"; }
X class: while ($class = pop(gh)) {
X if (index($one_of_these,":$class:") >=0) {
X $iter = 0;
X `exec crypt -inquire <$scan >.x 2>/dev/null`;
X unless (open(scan,'.x')) {
X print "Can't run $scan: $!\n";
X next scan;
X }
X $cmd = <scan>;
X unless ($cmd =~ s/#!(.*)\n/$1/) {
X $cmd = '/usr/bin/perl';
X }
X close(scan);
X if (open(pipe,"exec rsh $host '$cmd' <.x|")) {
X sleep(5);
X unlink '.x';
X while (<pipe>) {
X last if $iter++ > 1000; # must be looping
X next if /^[0-9.]+u [0-9.]+s/;
X print $showhost,$_;
X }
X close(pipe);
X } else {
X print "(Can't execute rsh: $!)\n";
X }
X last class;
X }
X }
X }
X}
!STUFFY!FUNK!
echo Extracting t/op.dbm
sed >t/op.dbm <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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 at keys = keys(%h);
X at 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 at 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/gsh.man
sed >eg/g/gsh.man <<'!STUFFY!FUNK!' -e 's/X//'
X.\" $Header: gsh.man,v 2.0 88/06/05 00:17:23 root Exp $
X.TH GSH 8 "13 May 1988"
X.SH NAME
Xgsh \- global shell
X.SH SYNOPSIS
X.B gsh
X[options]
X.I host
X[options]
X.I command
X.SH DESCRIPTION
X.I gsh
Xworks just like rsh(1C) except that you may specify a set of hosts to execute
Xthe command on.
XThe host sets are defined in the file /etc/ghosts.
X(An individual host name can be used as a set containing one member.)
XYou can give a command like
X
X gsh sun /etc/mungmotd
X
Xto run /etc/mungmotd on all your Suns.
X.P
XYou may specify the union of two or more sets by using + as follows:
X
X gsh 750+mc /etc/mungmotd
X
Xwhich will run mungmotd on all 750's and Masscomps.
X.P
XCommonly used sets should be defined in /etc/ghosts.
XFor example, you could add a line that says
X
X pep=manny+moe+jack
X
XAnother way to do that would be to add the word "pep" after each of the host
Xentries:
X
X manny sun3 pep
X.br
X moe sun3 pep
X.br
X jack sun3 pep
X
XHosts and sets of host can also be excluded:
X
X foo=sun-sun2
X
XAny host so excluded will never be included, even if a subsequent set on the
Xline includes it:
X
X foo=abc+def
X bar=xyz-abc+foo
X
Xcomes out to xyz+def.
X
XYou can define private host sets by creating .ghosts in your current directory
Xwith entries just like /etc/ghosts.
XAlso, if there is a file .grem, it defines "rem" to be the remaining hosts
Xfrom the last gsh or gcp that didn't succeed everywhere.
X
XOptions include all those defined by rsh, as well as
X
X.IP "\-d" 8
XCauses gsh to collect input till end of file, and then distribute that input
Xto each invokation of rsh.
X.IP "\-h" 8
XRather than print out the command followed by the output, merely prepends the
Xhost name to each line of output.
X.IP "\-s" 8
XDo work silently.
X.PP
XInterrupting with a SIGINT will cause the rsh to the current host to be skipped
Xand execution resumed with the next host.
XTo stop completely, send a SIGQUIT.
X.SH SEE ALSO
Xrsh(1C)
X.SH BUGS
XAll the bugs of rsh, since it calls rsh.
X
XAlso, will not properly return data from the remote execution that contains
Xnull characters.
!STUFFY!FUNK!
echo Extracting handy.h
sed >handy.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: handy.h,v 2.0.1.2 88/10/31 16:29:01 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 */
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#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 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#define Safefree(d) safefree((char*)d)
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.man
sed >eg/g/gcp.man <<'!STUFFY!FUNK!' -e 's/X//'
X.\" $Header: gcp.man,v 2.0 88/06/05 00:17:05 root Exp $
X.TH GCP 1C "13 May 1988"
X.SH NAME
Xgcp \- global file copy
X.SH SYNOPSIS
X.B gcp
Xfile1 file2
X.br
X.B gcp
X[
X.B \-r
X] file ... directory
X.SH DESCRIPTION
X.I gcp
Xworks just like rcp(1C) except that you may specify a set of hosts to copy files
Xfrom or to.
XThe host sets are defined in the file /etc/ghosts.
X(An individual host name can be used as a set containing one member.)
XYou can give a command like
X
X gcp /etc/motd sun:
X
Xto copy your /etc/motd file to /etc/motd on all the Suns.
XIf, on the other hand, you say
X
X gcp /a/foo /b/bar sun:/tmp
X
Xthen your files will be copied to /tmp on all the Suns.
XThe general rule is that if you don't specify the destination directory,
Xfiles go to the same directory they are in currently.
X.P
XYou may specify the union of two or more sets by using + as follows:
X
X gcp /a/foo /b/bar 750+mc:
X
Xwhich will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
X/b/bar to /b/bar on all 750's and Masscomps.
X.P
XCommonly used sets should be defined in /etc/ghosts.
XFor example, you could add a line that says
X
X pep=manny+moe+jack
X
XAnother way to do that would be to add the word "pep" after each of the host
Xentries:
X
X manny sun3 pep
X.br
X moe sun3 pep
X.br
X jack sun3 pep
X
XHosts and sets of host can also be excluded:
X
X foo=sun-sun2
X
XAny host so excluded will never be included, even if a subsequent set on the
Xline includes it:
X
X foo=abc+def
X.br
X bar=xyz-abc+foo
X
Xcomes out to xyz+def.
X
XYou can define private host sets by creating .ghosts in your current directory
Xwith entries just like /etc/ghosts.
XAlso, if there is a file .grem, it defines "rem" to be the remaining hosts
Xfrom the last gsh or gcp that didn't succeed everywhere.
X.PP
XInterrupting with a SIGINT will cause the rcp to the current host to be skipped
Xand execution resumed with the next host.
XTo stop completely, send a SIGQUIT.
X.SH SEE ALSO
Xrcp(1C)
X.SH BUGS
XAll the bugs of rcp, since it calls rcp.
!STUFFY!FUNK!
echo Extracting lib/complete.pl
sed >lib/complete.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;#
X;# @(#)complete.pl 1.0 (sun!waynet) 11/11/88
X;#
X;# Author: Wayne Thompson
X;#
X;# Description:
X;# This routine provides word completion.
X;# (TAB) attempts word completion.
X;# (^D) prints completion list.
X;#
X;# Diagnostics:
X;# Bell when word completion fails.
X;#
X;# Dependencies:
X;# The tty driver is put into raw mode.
X;#
X;# Bugs:
X;# The erase and kill characters are hard coded.
X;#
X;# Usage:
X;# $input = do Complete('prompt_string', @completion_list);
X;#
X
Xsub Complete {
X local ($prompt) = shift (@_);
X local ($c, $cmp, $l, $r, $ret, $return, $test);
X @_ = sort @_;
X system 'stty raw -echo';
X loop: {
X print $prompt, $return;
X while (($c = getc(stdin)) ne "\r") {
X if ($c eq "\t") { # (TAB) attempt completion
X @_match = ();
X foreach $cmp (@_) {
X push (@_match, $cmp) if $cmp =~ /^$return/;
X }
X $test = $_match[0];
X $l = length ($test);
X unless ($#_match == 0) {
X shift (@_match);
X foreach $cmp (@_match) {
X until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) {
X $l--;
X }
X }
X print "\007";
X }
X print $test = substr ($test, $r, $l - $r);
X $r = length ($return .= $test);
X }
X elsif ($c eq "\004") { # (^D) completion list
X print "\r\n";
X foreach $cmp (@_) {
X print "$cmp\r\n" if $cmp =~ /^$return/;
X }
X redo loop;
X }
X elsif ($c eq "\025" && $r) { # (^U) kill
X $return = '';
X $r = 0;
X print "\r\n";
X redo loop;
X }
X # (DEL) || (BS) erase
X elsif ($c eq "\177" || $c eq "\010") {
X if($r) {
X print "\b \b";
X chop ($return);
X $r--;
X }
X }
X elsif ($c =~ /\S/) { # printable char
X $return .= $c;
X $r++;
X print $c;
X }
X }
X }
X system 'stty -raw echo';
X print "\n";
X $return;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting t/op.study
sed >t/op.study <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.study,v 2.0 88/06/05 00:14:45 root Exp $
X
Xprint "1..24\n";
X
X$x = "abc\ndef\n";
Xstudy($x);
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';
Xstudy;
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
Xstudy($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';
Xstudy;
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';
Xstudy;
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';
Xstudy;
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';
Xstudy;
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";}
!STUFFY!FUNK!
echo Extracting t/TEST
sed >t/TEST <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: TEST,v 2.0.1.1 88/07/12 17:36:43 root Exp $
X
X# This is written in a peculiar style, since we're trying to avoid
X# most of the constructs we'll be testing for.
X
Xif ($ARGV[0] eq '-v') {
X $verbose = 1;
X shift;
X}
X
Xchdir 't' if -f 't/TEST';
X
Xif ($ARGV[0] eq '') {
X @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`);
X}
X
Xopen(config,"../config.sh");
Xwhile (<config>) {
X if (/sharpbang='(.*)'/) {
X $sharpbang = ($1 eq '#!');
X last;
X }
X}
X$bad = 0;
Xwhile ($test = shift) {
X if ($test =~ /\.orig$/) {
X next;
X }
X if ($test =~ /~$/) {
X next;
X }
X print "$test" . '.' x (16 - length($test));
X if ($sharpbang) {
X open(results,"./$test|") || (print "can't run.\n");
X } else {
X open(script,"$test") || die "Can't run $test.\n";
X $_ = <script>;
X close(script);
X if (/#!..perl(.*)/) {
X $switch = $1;
X } else {
X $switch = '';
X }
X open(results,"./perl$switch $test|") || (print "can't run.\n");
X }
X $ok = 0;
X $next = 0;
X while (<results>) {
X if ($verbose) {
X print $_;
X }
X unless (/^#/) {
X if (/^1\.\.([0-9]+)/) {
X $max = $1;
X $next = 1;
X $ok = 1;
X } else {
X if (/^ok (.*)/ && $1 == $next) {
X $next = $next + 1;
X } else {
X $ok = 0;
X }
X }
X }
X }
X $next = $next - 1;
X if ($ok && $next == $max) {
X print "ok\n";
X } else {
X $next += 1;
X print "FAILED on test $next\n";
X $bad = $bad + 1;
X $_ = $test;
X if (/^base/) {
X die "Failed a basic test--cannot continue.\n";
X }
X }
X}
X
Xif ($bad == 0) {
X if ($ok) {
X print "All tests successful.\n";
X } else {
X die "FAILED--no tests were run for some reason.\n";
X }
X} else {
X if ($bad == 1) {
X die "Failed 1 test.\n";
X } else {
X die "Failed $bad tests.\n";
X }
X}
X($user,$sys,$cuser,$csys) = times;
Xprint sprintf("u=%g s=%g cu=%g cs=%g\n",$user,$sys,$cuser,$csys);
!STUFFY!FUNK!
echo Extracting t/cmd.switch
sed >t/cmd.switch <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
X
Xprint "1..18\n";
X
Xsub foo1 {
X $_ = shift(@_);
X $a = 0;
X until ($a++) {
X next if $_ eq 1;
X next if $_ eq 2;
X next if $_ eq 3;
X next if $_ eq 4;
X return 20;
X }
X continue {
X return $_;
X }
X}
X
Xprint do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n";
Xprint do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n";
Xprint do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n";
Xprint do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n";
Xprint do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n";
Xprint do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n";
X
Xsub foo2 {
X $_ = shift(@_);
X {
X last if $_ == 1;
X last if $_ == 2;
X last if $_ == 3;
X last if $_ == 4;
X }
X continue {
X return 20;
X }
X return $_;
X}
X
Xprint do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n";
Xprint do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n";
Xprint do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n";
Xprint do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n";
Xprint do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n";
Xprint do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n";
X
Xsub foo3 {
X $_ = shift(@_);
X if (/^1/) {
X return 1;
X }
X elsif (/^2/) {
X return 2;
X }
X elsif (/^3/) {
X return 3;
X }
X elsif (/^4/) {
X return 4;
X }
X else {
X return 20;
X }
X return 40;
X}
X
Xprint do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n";
Xprint do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n";
Xprint do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n";
Xprint do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n";
Xprint do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n";
Xprint do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n";
!STUFFY!FUNK!
echo Extracting eg/van/unvanish
sed >eg/van/unvanish <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: unvanish,v 2.0 88/06/05 00:17:30 root Exp $
X
Xsub it {
X if ($olddir ne '.') {
X chop($pwd = `pwd`) if $pwd eq '';
X (chdir $olddir) || die "Directory $olddir is not accesible";
X }
X unless ($olddir eq '.deleted') {
X if (-d '.deleted') {
X chdir '.deleted' || die "Directory .deleted is not accesible";
X }
X else {
X chop($pwd = `pwd`) if $pwd eq '';
X die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
X }
X }
X print `mv $startfiles$filelist..$force`;
X if ($olddir ne '.') {
X (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
X }
X}
X
Xif ($#ARGV < 0) {
X open(lastcmd,'.deleted/.lastcmd') ||
X open(lastcmd,'.lastcmd') ||
X die "No previous vanish in this dir";
X $ARGV = <lastcmd>;
X close(lastcmd);
X @ARGV = split(/[\n ]+/,$ARGV);
X}
X
Xwhile ($ARGV[0] =~ /^-/) {
X $_ = shift;
X /^-f/ && ($force = ' >/dev/null 2>&1');
X /^-i/ && ($interactive = 1);
X if (/^-+$/) {
X $startfiles = '- ';
X last;
X }
X}
X
Xwhile ($file = shift) {
X if ($file =~ s|^(.*)/||) {
X $dir = $1;
X }
X else {
X $dir = '.';
X }
X
X if ($dir ne $olddir) {
X do it() if $olddir;
X $olddir = $dir;
X }
X
X if ($interactive) {
X print "unvanish: restore $dir/$file? ";
X next unless <stdin> =~ /^y/i;
X }
X
X $filelist .= $file; $filelist .= ' ';
X
X}
X
Xdo it() if $olddir;
!STUFFY!FUNK!
echo Extracting eg/van/vanish
sed >eg/van/vanish <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: vanish,v 2.0 88/06/05 00:17:36 root Exp $
X
Xsub it {
X if ($olddir ne '.') {
X chop($pwd = `pwd`) if $pwd eq '';
X (chdir $olddir) || die "Directory $olddir is not accesible";
X }
X if (!-d .deleted) {
X print `mkdir .deleted; chmod 775 .deleted`;
X die "You can't remove files from $olddir" if $?;
X }
X $filelist =~ s/ $//;
X $filelist =~ s/#/\\#/g;
X if ($filelist !~ /^[ \t]*$/) {
X open(lastcmd,'>.deleted/.lastcmd');
X print lastcmd $filelist,"\n";
X close(lastcmd);
X print `/bin/mv $startfiles$filelist .deleted$force`;
X }
X if ($olddir ne '.') {
X (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
X }
X}
X
Xwhile ($ARGV[0] =~ /^-/) {
X $_ = shift;
X /^-f/ && ($force = ' >/dev/null 2>&1');
X /^-i/ && ($interactive = 1);
X if (/^-+$/) {
X $startfiles = '- ';
X last;
X }
X}
X
Xchop($pwd = `pwd`);
X
Xwhile ($file = shift) {
X if ($file =~ s|^(.*)/||) {
X $dir = $1;
X }
X else {
X $dir = '.';
X }
X
X if ($interactive) {
X print "vanish: remove $dir/$file? ";
X next unless <stdin> =~ /^y/i;
X }
X
X if ($file eq '.deleted') {
X print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
X next;
X }
X
X if ($dir ne $olddir) {
X do it() if $olddir;
X $olddir = $dir;
X }
X
X $filelist .= $file; $filelist .= ' ';
X}
X
Xdo it() if $olddir;
!STUFFY!FUNK!
echo ""
echo "End of kit 21 (of 23)"
cat /dev/null >kit21isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
More information about the Alt.sources
mailing list