Usenet 1994 October

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

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

Wrap

Internet Message Format | 1991-04-20 | 49.4 KB

From: lwall@netlabs.com (Larry Wall) Newsgroups: comp.sources.misc Subject: v18i051: perl - The perl programming language, Part33/36 Message-ID: <1991Apr19.014936.5069@sparky.IMD.Sterling.COM> Date: 19 Apr 91 01:49:36 GMT Approved: kent@sparky.imd.sterling.com X-Checksum-Snefru: 4040c005 d15796d7 597e9da8 cf51eb08 Submitted-by: Larry Wall <lwall@netlabs.com> Posting-number: Volume 18, Issue 51 Archive-name: perl/part33 [There are 36 kits for perl version 4.0.] #! /bin/sh # Make a new directory for the perl sources, cd to it, and run kits 1 # thru 36 through sh. When all 36 kits have been run, read README. echo "This is perl 4.0 kit 33 (of 36). If kit 33 is complete, the line" echo '"'"End of kit 33 (of 36)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir eg eg/g eg/scan os2 t t/cmd t/comp t/io t/op usub x2p 2>/dev/null echo Extracting os2/makefile sed >os2/makefile <<'!STUFFY!FUNK!' -e 's/X//' X# X# Makefile for compiling Perl under OS/2 X# X# Needs a Unix compatible make. X# This makefile works for an initial compilation. It does not X# include all dependencies and thus is unsuitable for serious X# development work. Hey, I'm just inheriting what Diomidis gave me. X# X# Originally by Diomidis Spinellis, March 1990 X# Adjusted for OS/2 port by Raymond Chen, June 1990 X# X X# Source files XSRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \ Xeval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \ Xstab.c str.c toke.c util.c os2.c popen.c director.c suffix.c mktemp.c X X# Object files XOBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ Xdolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \ Xregexec.obj stab.obj str.obj toke.obj util.obj os2.obj popen.obj \ Xdirector.obj suffix.obj mktemp.obj X X# Files in the OS/2 distribution XDOSFILES=config.h director.c dir.h makefile os2.c popen.c suffix.c \ Xmktemp.c readme.os2 X X# Yacc flags XYFLAGS=-d X X# Manual pages XMAN=perlman.1 perlman.2 perlman.3 perlman.4 X XCC=cl X# CBASE = flags everybody gets X# CPLAIN = flags for modules that give the compiler indigestion X# CFLAGS = flags for milder modules X# PERL = which version of perl to build X# X# For preliminary building: No optimization, DEBUGGING set, symbols included. X#CBASE=-AL -Zi -G2 -Gs -DDEBUGGING X#CPLAIN=$(CBASE) -Od X#CFLAGS=$(CBASE) -Od X#PERL=perlsym.exe X X# For the final build: Optimization on, symbols stripped. XCBASE=-AL -Zi -G2 -Gs -DDEBUGGING XCPLAIN=$(CBASE) -Olt XCFLAGS=$(CBASE) -Oeglt XPERL=perl.exe X X# Destination directory for executables XDESTDIR=\usr\bin X X# Deliverables X# Xall: $(PERL) glob.exe X Xperl.exe: $(OBJ) perl.arp X link @perl.arp,perl,nul,/stack:32767 /NOE; X exehdr /nologo /newfiles /pmtype:windowcompat perl.exe >nul X Xperlsym.exe: $(OBJ) perl.arp X link @perl.arp,perlsym,nul,/stack:32767 /NOE /CODE; X exehdr /nologo /newfiles /pmtype:windowcompat perlsym.exe >nul X Xperl.arp: X echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp X echo eval+form+hash+perl+perly+regcomp+regexec+stab+suffix+ >>perl.arp X echo str+toke+util+os2+popen+director+\c600\lib\setargv >>perl.arp X Xglob.exe: glob.c X $(CC) glob.c setargv.obj -link /NOE X exehdr /nologo /newfiles /pmtype:windowcompat glob.exe >nul X Xarray.obj: array.c X $(CC) $(CPLAIN) -c array.c Xcmd.obj: cmd.c Xcons.obj: cons.c perly.h Xconsarg.obj: consarg.c X# $(CC) $(CPLAIN) -c consarg.c Xdoarg.obj: doarg.c Xdoio.obj: doio.c Xdolist.obj: dolist.c Xdump.obj: dump.c Xeval.obj: eval.c evalargs.xc X $(CC) /B2c2l /B3c3l $(CFLAGS) -c eval.c Xform.obj: form.c Xhash.obj: hash.c Xperl.obj: perl.y Xperly.obj: perly.c Xregcomp.obj: regcomp.c Xregexec.obj: regexec.c Xstab.obj: stab.c X $(CC) $(CPLAIN) -c stab.c Xstr.obj: str.c Xsuffix.obj: suffix.c Xtoke.obj: toke.c X $(CC) /B3c3l $(CFLAGS) -c toke.c Xutil.obj: util.c X# $(CC) $(CPLAIN) -c util.c Xperly.h: ytab.h X cp ytab.h perly.h Xdirector.obj: director.c Xpopen.obj: popen.c Xos2.obj: os2.c X Xperl.1: $(MAN) X nroff -man $(MAN) >perl.1 X Xinstall: all X exepack perl.exe $(DESTDIR)\perl.exe X exepack glob.exe $(DESTDIR)\glob.exe X Xclean: X rm -f *.obj *.exe perl.1 perly.h perl.arp X Xtags: X ctags *.c *.h *.xc X Xdosperl: X mv $(DOSFILES) ../perl30.new X Xdoskit: X mv $(DOSFILES) ../os2 !STUFFY!FUNK! echo Extracting os2/Makefile sed >os2/Makefile <<'!STUFFY!FUNK!' -e 's/X//' X# X# Makefile for compiling Perl under OS/2 X# X# Needs a Unix compatible make. X# This makefile works for an initial compilation. It does not X# include all dependencies and thus is unsuitable for serious X# development work. Hey, I'm just inheriting what Diomidis gave me. X# X# Originally by Diomidis Spinellis, March 1990 X# Adjusted for OS/2 port by Raymond Chen, June 1990 X# X X# Source files XSRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \ Xeval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \ Xstab.c str.c toke.c util.c os2.c popen.c director.c X X# Object files XOBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ Xdolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \ Xregexec.obj stab.obj str.obj toke.obj util.obj os2.obj popen.obj \ Xdirector.obj suffix.obj X X# Files in the OS/2 distribution XDOSFILES=config.h director.c makefile os2.c popen.c suffix.c readme.os2 X X# Yacc flags XYFLAGS=-d X X# Manual pages XMAN=perlman.1 perlman.2 perlman.3 perlman.4 X XCC=cl X# CBASE = flags everybody gets X# CPLAIN = flags for modules that give the compiler indigestion X# CFLAGS = flags for milder modules X# PERL = which version of perl to build X# X# For preliminary building: No optimization, DEBUGGING set, symbols included. X#CBASE=-AL -Zi -G2 -Gs -DDEBUGGING X#CPLAIN=$(CBASE) -Od X#CFLAGS=$(CBASE) -Od X#PERL=perlsym.exe X X# For the final build: Optimization on, no DEBUGGING, symbols stripped. XCBASE=-AL -Zi -G2 -Gs XCPLAIN=$(CBASE) -Oilt XCFLAGS=$(CBASE) -Ox XPERL=perl.exe X X# Destination directory for executables XDESTDIR=\usr\bin X X# Deliverables X# Xall: $(PERL) glob.exe X Xperl.exe: $(OBJ) perl.arp X link @perl.arp,perl,nul,/stack:32767 /NOE; X exehdr /nologo /newfiles /pmtype:windowcompat perl.exe >nul X Xperlsym.exe: $(OBJ) perl.arp X link @perl.arp,perlsym,nul,/stack:32767 /NOE /CODE; X exehdr /nologo /newfiles /pmtype:windowcompat perlsym.exe >nul X Xperl.arp: X echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp X echo eval+form+hash+perl+perly+regcomp+regexec+stab+suffix+ >>perl.arp X echo str+toke+util+os2+popen+director+\c600\lib\setargv >>perl.arp X Xglob.exe: glob.c X $(CC) glob.c \c600\lib\setargv.obj -link /NOE X exehdr /nologo /newfiles /pmtype:windowcompat glob.exe >nul X Xarray.obj: array.c X $(CC) $(CPLAIN) -c array.c Xcmd.obj: cmd.c Xcons.obj: cons.c perly.h Xconsarg.obj: consarg.c X# $(CC) $(CPLAIN) -c consarg.c Xdoarg.obj: doarg.c Xdoio.obj: doio.c Xdolist.obj: dolist.c Xdump.obj: dump.c Xeval.obj: eval.c evalargs.xc X $(CC) /B3 \c600\binp\c3l $(CFLAGS) -c eval.c Xform.obj: form.c Xhash.obj: hash.c Xperl.obj: perl.y Xperly.obj: perly.c Xregcomp.obj: regcomp.c Xregexec.obj: regexec.c Xstab.obj: stab.c X $(CC) $(CPLAIN) -c stab.c Xstr.obj: str.c Xsuffix.obj: suffix.c Xtoke.obj: toke.c X $(CC) /B3 \c600\binp\c3l $(CFLAGS) -c toke.c Xutil.obj: util.c X# $(CC) $(CPLAIN) -c util.c Xperly.h: ytab.h X cp ytab.h perly.h Xdirector.obj: director.c Xpopen.obj: popen.c Xos2.obj: os2.c X Xperl.1: $(MAN) X nroff -man $(MAN) >perl.1 X Xinstall: all X exepack perl.exe $(DESTDIR)\perl.exe X exepack glob.exe $(DESTDIR)\glob.exe X Xclean: X rm -f *.obj *.exe perl.1 perly.h perl.arp X Xtags: X ctags *.c *.h *.xc X Xdosperl: X mv $(DOSFILES) ../perl30.new X Xdoskit: X mv $(DOSFILES) ../os2 !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 -s ../config.sh . || \ X ln ../../config.sh . || \ X ln ../../../config.sh . || \ X (echo "Can't find config.sh."; exit 1) X fi 2>/dev/null 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 4.0 91/03/20 01:57:03 lwall Locked $ X# X# $Log: Makefile.SH,v $ X# Revision 4.0 91/03/20 01:57:03 lwall X# 4.0 baseline. X# X# X XCC = $cc XYACC = $yacc Xbin = $bin Xlib = $lib Xmansrc = $mansrc Xmanext = $manext XCFLAGS = $ccflags $optimize XLDFLAGS = $ldflags XSMALL = $small XLARGE = $large $split Xmallocsrc = $mallocsrc Xmallocobj = $mallocobj X Xlibs = $libs X!GROK!THIS! X Xcat >>Makefile <<'!NO!SUBS!' X Xpublic = a2p s2p find2perl 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 226 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 str.h hash.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 a2p *.o X Xrealclean: clean X rm -f *.orig */*.orig core $(addedbyconf) a2p.c s2p all 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 Xconfig.sh: ../config.sh X rm -f config.sh X ln ../config.sh . 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/re_tests sed >t/op/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)))))))))) a y $10 a X((((((((((a))))))))))\10 aa y $& aa X((((((((((a))))))))))\41 aa n - - X((((((((((a))))))))))\41 a! y $& a! 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 eg/g/gsh sed >eg/g/gsh <<'!STUFFY!FUNK!' -e 's/X//' X#! /usr/bin/perl X X# $Header: gsh,v 4.0 91/03/20 01:10:40 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(@ARGV),next); X $ARGV[0] =~ /^-s/ && ($silent++,shift(@ARGV),next); X $ARGV[0] =~ /^-d/ && ($dodist++,shift(@ARGV),next); X $ARGV[0] =~ /^-n/ && ($n=' -n',shift(@ARGV),next); X $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift(@ARGV),shift(@ARGV), X 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/io/fs.t sed >t/io/fs.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: fs.t,v 4.0 91/03/20 01:50:55 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) || $wd =~ m#/afs/#) X {print "ok 18\n";} Xelse X {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.t sed >t/comp/cmdopt.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: cmdopt.t,v 4.0 91/03/20 01:49:58 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 t/op/auto.t sed >t/op/auto.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: auto.t,v 4.0 91/03/20 01:51:35 lwall Locked $ 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.t sed >t/op/list.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: list.t,v 4.0 91/03/20 01:53:24 lwall Locked $ X Xprint "1..27\n"; X X@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(':',@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@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@foo = @bar = (1); Xif (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";} X X@foo = (); X@foo = 1+2+3; Xif (join(':',@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@a = ($x == 12345 || (1,2,3)); Xif (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";} X X@a = ($x == $x || (4,5,6)); Xif (join('',@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 usub/mus sed >usub/mus <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X Xwhile (<>) { X if (s/^CASE\s+//) { X @fields = split; X $funcname = pop(@fields); X $rettype = "@fields"; X @modes = (); X @types = (); X @names = (); X @outies = (); X @callnames = (); X $pre = "\n"; X $post = ''; X X while (<>) { X last unless /^[IO]+\s/; X @fields = split(' '); X push(@modes, shift(@fields)); X push(@names, pop(@fields)); X push(@types, "@fields"); X } X while (s/^<\s//) { X $pre .= "\t $_"; X $_ = <>; X } X while (s/^>\s//) { X $post .= "\t $_"; X $_ = <>; X } X $items = @names; X $namelist = '$' . join(', $', @names); X $namelist = '' if $namelist eq '$'; X print <<EOF; X case US_$funcname: X if (items != $items) X fatal("Usage: &$funcname($namelist)"); X else { XEOF X if ($rettype eq 'void') { X print <<EOF; X int retval = 1; XEOF X } X else { X print <<EOF; X $rettype retval; XEOF X } X foreach $i (1..@names) { X $mode = $modes[$i-1]; X $type = $types[$i-1]; X $name = $names[$i-1]; X if ($type =~ /^[A-Z]+\*$/) { X $cast = "*($type*)"; X } X else { X $cast = "($type)"; X } X $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum"); X $type .= "\t" if length($type) < 4; X $cast .= "\t" if length($cast) < 8; X $x = "\t" x (length($name) < 6); X if ($mode =~ /O/) { X if ($what eq 'gnum') { X push(@outies, "\t str_numset(st[$i], (double) $name);\n"); X } X else { X push(@outies, "\t str_set(st[$i], (char*) $name);\n"); X } X push(@callnames, "&$name"); X } X else { X push(@callnames, $name); X } X if ($mode =~ /I/) { X print <<EOF; X $type $name =$x $cast str_$what(st[$i]); XEOF X } X else { X print <<EOF; X $type $name; XEOF X } X } X $callnames = join(', ', @callnames); X $outies = join("\n",@outies); X if ($rettype eq 'void') { X print <<EOF; X$pre (void)$funcname($callnames); XEOF X } X else { X print <<EOF; X$pre retval = $funcname($callnames); XEOF X } X if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) { X print <<EOF; X str_set(st[0], (char*) retval); XEOF X } X elsif ($rettype =~ /^[A-Z]+\s*\*$/) { X print <<EOF; X str_nset(st[0], (char*) &retval, sizeof retval); XEOF X } X else { X print <<EOF; X str_numset(st[0], (double) retval); XEOF X } X print $outies if $outies; X print $post if $post; X if (/^END/) { X print "\t}\n\treturn sp;\n"; X } X else { X redo; X } X } X elsif (/^END/) { X print "\t}\n\treturn sp;\n"; X } X else { X print; 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 4.0 91/03/20 01:10:05 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.t sed >t/cmd/while.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: while.t,v 4.0 91/03/20 01:49:51 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 t/op/dbm.t sed >t/op/dbm.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: dbm.t,v 4.0 91/03/20 01:51:52 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..12\n"; X Xunlink <Op.dbmx.*>; 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$h{'foo'} = ''; X$h{''} = 'bar'; 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 X@h{0..200} = 200..400; X@foo = @h{0..200}; Xprint join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; X Xprint ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); Xprint ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); X Xunlink 'Op.dbmx.dir', 'Op.dbmx.pag'; !STUFFY!FUNK! echo Extracting eg/relink sed >eg/relink <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X'di'; X'ig00'; X# X# $Header: relink,v 4.0 91/03/20 01:11:40 lwall Locked $ X# X# $Log: relink,v $ X# Revision 4.0 91/03/20 01:11:40 lwall X# 4.0 baseline. X# X# Revision 3.0.1.2 90/08/09 03:17:44 lwall X# patch19: added man page for relink and rename X# X X($op = shift) || die "Usage: relink perlexpr [filenames]\n"; Xif (!@ARGV) { X @ARGV = <STDIN>; X chop(@ARGV); X} Xfor (@ARGV) { X next unless -l; # symbolic link? X $name = $_; X $_ = readlink($_); X $was = $_; X eval $op; X die $@ if $@; X if ($was ne $_) { X unlink($name); X symlink($_, $name); X } X} X############################################################################## X X # These next few lines are legal in both Perl and nroff. X X.00; # finish .ig X X'di \" finish diversion--previous line must be blank X.nr nl 0-1 \" fake up transition to first page again X.nr % 0 \" start at page 1 X';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ X.TH RELINK 1 "July 30, 1990" X.AT 3 X.SH LINK Xrelink \- relinks multiple symbolic links X.SH SYNOPSIS X.B relink perlexpr [symlinknames] X.SH DESCRIPTION X.I Relink Xrelinks the symbolic links given according to the rule specified as the Xfirst argument. XThe argument is a Perl expression which is expected to modify the $_ Xstring in Perl for at least some of the names specified. XFor each symbolic link named on the command line, the Perl expression Xwill be executed on the contents of the symbolic link with that name. XIf a given symbolic link's contents is not modified by the expression, Xit will not be changed. XIf a name given on the command line is not a symbolic link, it will be ignored. XIf no names are given on the command line, names will be read Xvia standard input. X.PP XFor example, to relink all symbolic links in the current directory Xpointing to somewhere in X11R3 so that they point to X11R4, you might say X.nf X X relink 's/X11R3/X11R4/' * X X.fi XTo change all occurences of links in the system from /usr/spool to /var/spool, Xyou'd say X.nf X X find / -type l -print | relink 's#/usr/spool#/var/spool#' X X.fi X.SH ENVIRONMENT XNo environment variables are used. X.SH FILES X.SH AUTHOR XLarry Wall X.SH "SEE ALSO" Xln(1) X.br Xperl(1) X.SH DIAGNOSTICS XIf you give an invalid Perl expression you'll get a syntax error. X.SH BUGS X.ex !STUFFY!FUNK! echo Extracting x2p/s2p.man sed >x2p/s2p.man <<'!STUFFY!FUNK!' -e 's/X//' X.rn '' }` X''' $Header: s2p.man,v 4.0 91/03/20 01:58:07 lwall Locked $ X''' X''' $Log: s2p.man,v $ X''' Revision 4.0 91/03/20 01:58:07 lwall X''' 4.0 baseline. X''' 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 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 4.0 91/03/20 01:14:00 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 eg/g/gsh.man sed >eg/g/gsh.man <<'!STUFFY!FUNK!' -e 's/X//' X.\" $Header: gsh.man,v 4.0 91/03/20 01:10:46 lwall Locked $ 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 " " echo "End of kit 33 (of 36)" cat /dev/null >kit33isdone run='' config='' for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do if test -f kit${iskit}isdone; then run="$run $iskit" else todo="$todo $iskit" fi done case $todo in '') echo "You have run all your kits. Please read README and then type Configure." for combo in *:AA; do if test -f "$combo"; then realfile=`basename $combo :AA` cat $realfile:[A-Z][A-Z] >$realfile rm -rf $realfile:[A-Z][A-Z] fi done rm -rf kit*isdone chmod 755 Configure ;; *) echo "You have run$run." echo "You still need to run$todo." ;; esac : Someone might mail this, so... exit exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.