Subject: v20i107: Perl, a language with features of C/sed/awk/shell/etc, Part24/24 Newsgroups: comp.sources.unix Sender: sources Approved: rsalz@uunet.UU.NET Submitted-by: Larry Wall Posting-number: Volume 20, Issue 107 Archive-name: perl3.0/part24 #! /bin/sh # Make a new directory for the perl sources, cd to it, and run kits 1 # thru 24 through sh. When all 24 kits have been run, read README. echo "This is perl 3.0 kit 24 (of 24). If kit 24 is complete, the line" echo '"'"End of kit 24 (of 24)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir eg eg/g eg/scan eg/van lib t x2p 2>/dev/null echo Extracting t/op.regexp sed >t/op.regexp <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.regexp,v 3.0 89/10/18 15:31:02 lwall Locked $ X Xopen(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests"; Xwhile () { } X$numtests = $.; Xclose(TESTS); X Xprint "1..$numtests\n"; Xopen(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests"; Xwhile () { X ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_); X $input = join(':',$pat,$subject,$result,$repl,$expect); X eval "\$match = (\$subject =~ \$pat); \$got = \"$repl\";"; X if ($result eq 'c') { X if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";} X } X elsif ($result eq 'n') { X if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";} X } X else { X if ($match && $got eq $expect) { X print "ok $.\n"; X } X else { X print "not ok $. $input => $got\n"; X } X } X} Xclose(TESTS); !STUFFY!FUNK! echo Extracting t/op.vec sed >t/op.vec <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.vec,v 3.0 89/10/18 15:32:11 lwall Locked $ X Xprint "1..13\n"; X Xprint vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; Xprint length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; Xvec($foo,0,1) = 1; Xprint length($foo) == 1 ? "ok 3\n" : "not ok 3\n"; Xprint ord($foo) == 1 ? "ok 4\n" : "not ok 4\n"; Xprint vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n"; X Xprint vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n"; Xvec($foo,20,1) = 1; Xprint vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n"; Xprint length($foo) == 3 ? "ok 8\n" : "not ok 8\n"; Xprint vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n"; Xvec($foo,1,8) = 0xf1; Xprint vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; Xprint ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); Xprint vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; Xprint vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; X !STUFFY!FUNK! echo Extracting x2p/handy.h sed >x2p/handy.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: handy.h,v 3.0 89/10/18 15:34:44 lwall Locked $ X * X * Copyright (c) 1989, Larry Wall X * X * You may distribute under the terms of the GNU General Public License X * as specified in the README file that comes with the perl 3.0 kit. X * X * $Log: handy.h,v $ X * Revision 3.0 89/10/18 15:34:44 lwall X * 3.0 baseline X * X */ X X#define Null(type) ((type)0) X#define Nullch Null(char*) X#define Nullfp Null(FILE*) X X#define bool char 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)) !STUFFY!FUNK! echo Extracting x2p/util.h sed >x2p/util.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: util.h,v 3.0 89/10/18 15:35:41 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: util.h,v $ X * Revision 3.0 89/10/18 15:35:41 lwall X * 3.0 baseline X * X */ X X/* is the string for makedir a directory name or a filename? */ X X#define MD_DIR 0 X#define MD_FILE 1 X Xvoid util_init(); Xint doshell(); Xchar *safemalloc(); Xchar *saferealloc(); Xchar *safecpy(); Xchar *safecat(); Xchar *cpytill(); Xchar *cpy2(); Xchar *instr(); X#ifdef SETUIDGID X int eaccess(); X#endif Xchar *getwd(); Xvoid cat(); Xvoid prexit(); Xchar *get_a_line(); Xchar *savestr(); Xint makedir(); Xvoid setenv(); Xint envix(); Xvoid notincl(); Xchar *getval(); Xvoid growstr(); Xvoid setdef(); !STUFFY!FUNK! echo Extracting lib/getopts.pl sed >lib/getopts.pl <<'!STUFFY!FUNK!' -e 's/X//' X;# getopts.pl - a better getopt.pl X X;# Usage: X;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a X;# # side effect. X Xsub Getopts { X local($argumentative) = @_; X local(@args,$_,$first,$rest); X X @args = split( / */, $argumentative ); X while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) { X ($first,$rest) = ($1,$2); X $pos = index($argumentative,$first); X if($pos >= $[) { X if($args[$pos+1] eq ':') { X shift; X if($rest eq '') { X $rest = shift; X } X eval "\$opt_$first = \$rest;"; X } X else { X eval "\$opt_$first = 1"; X if($rest eq '') { X shift; X } X else { X $ARGV[0] = "-$rest"; X } X } X } X else { X print stderr "Unknown option: $first\n"; X if($rest ne '') { X $ARGV[0] = "-$rest"; X } X else { X shift; X } X } X } X} X X1; !STUFFY!FUNK! echo Extracting t/base.term sed >t/base.term <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: base.term,v 3.0 89/10/18 15:24:34 lwall Locked $ X Xprint "1..6\n"; X X# check "" interpretation X X$x = "\n"; Xif ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";} X X# check `` processing X X$x = `echo hi there`; Xif ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";} X X# check $#array X X$x[0] = 'foo'; X$x[1] = 'foo'; X$tmp = $#x; Xprint "#3\t:$tmp: == :1:\n"; Xif ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";} X X# check numeric literal X X$x = 1; Xif ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";} X X# check <> pseudoliteral X Xopen(try, "/dev/null") || (die "Can't open /dev/null."); Xif ( eq '') {print "ok 5\n";} else {print "not ok 5\n";} X Xopen(try, "../Makefile") || (die "Can't open ../Makefile."); Xif ( ne '') {print "ok 6\n";} else {print "not ok 6\n";} !STUFFY!FUNK! echo Extracting t/comp.multiline sed >t/comp.multiline <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: comp.multiline,v 3.0 89/10/18 15:25:39 lwall Locked $ X Xprint "1..5\n"; X Xopen(try,'>Comp.try') || (die "Can't open temp file."); X X$x = 'now is the time Xfor all good men Xto come to. X'; X X$y = 'now is the time' . "\n" . X'for all good men' . "\n" . X'to come to.' . "\n"; X Xif ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";} X Xprint try $x; Xclose try; X Xopen(try,'Comp.try') || (die "Can't reopen temp file."); X$count = 0; X$z = ''; Xwhile () { X $z .= $_; X $count = $count + 1; X} X Xif ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";} X Xif ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} X X$_ = `cat Comp.try`; X Xif (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} X`/bin/rm -f Comp.try`; X Xif ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} !STUFFY!FUNK! echo Extracting t/op.local sed >t/op.local <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.local,v 3.0 89/10/18 15:29:49 lwall Locked $ X Xprint "1..20\n"; X Xsub foo { X local($a, $b) = @_; X local($c, $d); X $c = "ok 3\n"; X $d = "ok 4\n"; X { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); } X print $a, $b; X $c . $d; X} X X$a = "ok 5\n"; X$b = "ok 6\n"; X$c = "ok 7\n"; X$d = "ok 8\n"; X Xprint do foo("ok 1\n","ok 2\n"); X Xprint $a,$b,$c,$d,$x,$y; X X# same thing, only with arrays and associative arrays X Xsub foo2 { X local($a, @b) = @_; X local(@c, %d); X @c = "ok 13\n"; X $d{''} = "ok 14\n"; X { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); } X print $a, @b; X $c[0] . $d{''}; X} X X$a = "ok 15\n"; X@b = "ok 16\n"; X@c = "ok 17\n"; X$d{''} = "ok 18\n"; X Xprint do foo2("ok 11\n","ok 12\n"); X Xprint $a,@b,@c,%d,$x,$y; !STUFFY!FUNK! echo Extracting eg/van/empty sed >eg/van/empty <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: empty,v 3.0 89/10/18 15:16:28 lwall Locked $ X X# This script empties a trashcan. X X$recursive = shift if $ARGV[0] eq '-r'; X X@ARGV = '.' if $#ARGV < 0; X Xchop($pwd = `pwd`); X Xdir: foreach $dir (@ARGV) { X unless (chdir $dir) { X print stderr "Can't find directory $dir: $!\n"; X next dir; X } X if ($recursive) { X do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); X } X else { X if (-d '.deleted') { X do cmd('rm -rf .deleted'); X } X else { X if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { X chdir '..'; X do cmd('rm -rf .deleted'); X } X else { X print stderr "No trashcan found in directory $dir\n"; X } X } X } X} Xcontinue { X chdir $pwd; X} X X# force direct execution with no shell X Xsub cmd { X system split(' ',join(' ',@_)); X} X !STUFFY!FUNK! echo Extracting t/comp.cpp sed >t/comp.cpp <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl -P X X# $Header: comp.cpp,v 3.0 89/10/18 15:25:19 lwall Locked $ X Xprint "1..3\n"; X X#this is a comment X#define MESS "ok 1\n" Xprint MESS; X X#If you capitalize, it's a comment. X#ifdef MESS X print "ok 2\n"; X#else X print "not ok 2\n"; X#endif X Xopen(try,">Comp.cpp.tmp") || die "Can't open temp perl file."; Xprint try '$ok = "not ok 3\n";'; print try "\n"; Xprint try "#include \n"; Xprint try "#ifdef OK\n"; Xprint try '$ok = OK;'; print try "\n"; Xprint try "#endif\n"; Xprint try 'print $ok;'; print try "\n"; Xclose try; X Xopen(try,">Comp.cpp.inc") || (die "Can't open temp include file."); Xprint try '#define OK "ok 3\n"'; print try "\n"; Xclose try; X X$pwd=`pwd`; X$pwd =~ s/\n//; X$x = `./perl -P -I$pwd Comp.cpp.tmp`; Xprint $x; X`/bin/rm -f Comp.cpp.tmp Comp.cpp.inc`; !STUFFY!FUNK! echo Extracting form.h sed >form.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: form.h,v 3.0 89/10/18 15:17:39 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: form.h,v $ X * Revision 3.0 89/10/18 15:17:39 lwall X * 3.0 baseline X * X */ X X#define F_NULL 0 X#define F_LEFT 1 X#define F_RIGHT 2 X#define F_CENTER 3 X#define F_LINES 4 X Xstruct formcmd { X struct formcmd *f_next; X ARG *f_expr; X STR *f_unparsed; X line_t f_line; X char *f_pre; X short f_presize; X short f_size; X char f_type; X char f_flags; X}; X X#define FC_CHOP 1 X#define FC_NOBLANK 2 X#define FC_MORE 4 X#define FC_REPEAT 8 X X#define Nullfcmd Null(FCMD*) X XEXT char *chopset INIT(" \n-"); !STUFFY!FUNK! echo Extracting eg/scan/scan_ps sed >eg/scan/scan_ps <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl -P X X# $Header: scan_ps,v 3.0 89/10/18 15:15:47 lwall Locked $ X X# This looks for looping processes. X X#if defined(mc300) || defined(mc500) || defined(mc700) Xopen(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; X Xwhile () { X next if /rwhod/; X print if index(' T', substr($_,62,1)) < 0; X} X#else Xopen(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; X Xwhile () { X next if /dataserver/; X next if /nfsd/; X next if /update/; X next if /ypserv/; X next if /rwhod/; X next if /routed/; X next if /pagedaemon/; X#ifdef vax X ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; X#else X ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; X#endif X print if length($time) > 4; X} X#endif !STUFFY!FUNK! echo Extracting t/op.index sed >t/op.index <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.index,v 3.0 89/10/18 15:29:29 lwall Locked $ X Xprint "1..6\n"; X X X$foo = 'Now is the time for all good men to come to the aid of their country.'; X X$first = substr($foo,0,index($foo,'the')); Xprint ($first eq "Now is " ? "ok 1\n" : "not ok 1\n"); X X$last = substr($foo,rindex($foo,'the'),100); Xprint ($last eq "their country." ? "ok 2\n" : "not ok 2\n"); X X$last = substr($foo,index($foo,'Now'),2); Xprint ($last eq "No" ? "ok 3\n" : "not ok 3\n"); X X$last = substr($foo,rindex($foo,'Now'),2); Xprint ($last eq "No" ? "ok 4\n" : "not ok 4\n"); X X$last = substr($foo,index($foo,'.'),100); Xprint ($last eq "." ? "ok 5\n" : "not ok 5\n"); X X$last = substr($foo,rindex($foo,'.'),100); Xprint ($last eq "." ? "ok 6\n" : "not ok 6\n"); !STUFFY!FUNK! echo Extracting t/op.delete sed >t/op.delete <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.delete,v 3.0 89/10/18 15:28:36 lwall Locked $ X Xprint "1..6\n"; X X$foo{1} = 'a'; X$foo{2} = 'b'; X$foo{3} = 'c'; X X$foo = delete $foo{2}; X Xif ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} Xif ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} Xif ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} Xif ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} X X$foo = join('',values(foo)); Xif ($foo eq 'ac' || $foo eq 'ca') {print "ok 5\n";} else {print "not ok 5\n";} X Xforeach $key (keys foo) { X delete $foo{$key}; X} X X$foo{'foo'} = 'x'; X$foo{'bar'} = 'y'; X X$foo = join('',values(foo)); Xif ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";} !STUFFY!FUNK! echo Extracting util.h sed >util.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: util.h,v 3.0 89/10/18 15:33:18 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: util.h,v $ X * Revision 3.0 89/10/18 15:33:18 lwall X * 3.0 baseline X * X */ X XEXT int *screamfirst INIT(Null(int*)); XEXT int *screamnext INIT(Null(int*)); X Xchar *safemalloc(); Xchar *saferealloc(); Xchar *cpytill(); Xchar *instr(); Xchar *fbminstr(); Xchar *screaminstr(); Xvoid fbmcompile(); Xchar *savestr(); Xvoid setenv(); Xint envix(); Xvoid growstr(); Xchar *ninstr(); Xchar *rninstr(); Xchar *nsavestr(); XFILE *mypopen(); Xint mypclose(); !STUFFY!FUNK! echo Extracting array.h sed >array.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: array.h,v 3.0 89/10/18 15:08:41 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: array.h,v $ X * Revision 3.0 89/10/18 15:08:41 lwall X * 3.0 baseline X * X */ X Xstruct atbl { X STR **ary_array; X STR **ary_alloc; X STR *ary_magic; X int ary_max; X int ary_fill; X int ary_index; X char ary_flags; X}; X X#define ARF_REAL 1 /* free old entries */ X XSTR *afetch(); Xbool astore(); XSTR *apop(); XSTR *ashift(); Xvoid afree(); Xvoid aclear(); Xbool apush(); Xint alen(); XARRAY *anew(); XARRAY *afake(); !STUFFY!FUNK! echo Extracting t/comp.package sed >t/comp.package <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X Xprint "1..7\n"; X X$blurfl = 123; X$foo = 3; X Xpackage XYZ; X X$bar = 4; X X{ X package ABC; X $blurfl = 5; X $main'a = $'b; X} X X$ABC'dyick = 6; X X$xyz = 2; X X$main = join(':', sort(keys _main)); X$XYZ = join(':', sort(keys _XYZ)); X$ABC = join(':', sort(keys _ABC)); X Xprint $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n"; Xprint $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2\n"; Xprint $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; Xpackage ABC; Xprint $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; Xeval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; Xeval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; Xprint $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; !STUFFY!FUNK! echo Extracting t/op.range sed >t/op.range <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.range,v 3.0 89/10/18 15:30:53 lwall Locked $ X Xprint "1..6\n"; X Xprint join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; X X@foo = (1,2,3,4,5,6,7,8,9); X@foo[2..4] = ('c','d','e'); X Xprint join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n"; X X@bar[2..4] = ('c','d','e'); Xprint join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n"; X X($a,@bcd[0..2],$e) = ('a','b','c','d','e'); Xprint join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n"; X X$x = 0; Xfor (1..100) { X $x += $_; X} Xprint $x == 5050 ? "ok 5\n" : "not ok 5 $x\n"; X X$x = 0; Xfor ((100,2..99,1)) { X $x += $_; X} Xprint $x == 5050 ? "ok 6\n" : "not ok 6 $x\n"; !STUFFY!FUNK! echo Extracting t/cmd.mod sed >t/cmd.mod <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: cmd.mod,v 3.0 89/10/18 15:24:48 lwall Locked $ X Xprint "1..7\n"; X Xprint "ok 1\n" if 1; Xprint "not ok 1\n" unless 1; X Xprint "ok 2\n" unless 0; Xprint "not ok 2\n" if 0; X X1 && (print "not ok 3\n") if 0; X1 && (print "ok 3\n") if 1; X0 || (print "not ok 4\n") if 0; X0 || (print "ok 4\n") if 1; X X$x = 0; Xdo {$x[$x] = $x;} while ($x++) < 10; Xif (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') { X print "ok 5\n"; X} else { X print "not ok 5\n"; X} X X$x = 15; X$x = 10 while $x < 10; Xif ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";} X Xopen(foo,'TEST') || open(foo,'t/TEST'); X$x = 0; X$x++ while ; Xprint $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n"; !STUFFY!FUNK! echo Extracting t/op.exec sed >t/op.exec <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.exec,v 3.0 89/10/18 15:28:57 lwall Locked $ X X$| = 1; # flush stdout Xprint "1..8\n"; X Xprint "not ok 1\n" if system "echo ok \\1"; # shell interpreted Xprint "not ok 2\n" if system "echo ok 2"; # split and directly called Xprint "not ok 3\n" if system "echo", "ok", "3"; # directly called X Xif (system "true") {print "not ok 4\n";} else {print "ok 4\n";} X Xif ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } Xprint "ok 5\n"; X Xif ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";} X Xunless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} X Xexec "echo","ok","8"; !STUFFY!FUNK! echo Extracting lib/stat.pl sed >lib/stat.pl <<'!STUFFY!FUNK!' -e 's/X//' X;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $ X X;# Usage: X;# @ary = stat(foo); X;# $st_dev = @ary[$ST_DEV]; X;# X$ST_DEV = 0 + $[; X$ST_INO = 1 + $[; X$ST_MODE = 2 + $[; X$ST_NLINK = 3 + $[; X$ST_UID = 4 + $[; X$ST_GID = 5 + $[; X$ST_RDEV = 6 + $[; X$ST_SIZE = 7 + $[; X$ST_ATIME = 8 + $[; X$ST_MTIME = 9 + $[; X$ST_CTIME = 10 + $[; X$ST_BLKSIZE = 11 + $[; X$ST_BLOCKS = 12 + $[; X X;# Usage: X;# do Stat('foo'); # sets st_* as a side effect X;# Xsub Stat { X ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, X $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); X} X X1; !STUFFY!FUNK! echo Extracting t/op.goto sed >t/op.goto <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.goto,v 3.0 89/10/18 15:29:24 lwall Locked $ X Xprint "1..3\n"; X Xwhile (0) { X $foo = 1; X label1: X $foo = 2; X goto label2; X} continue { X $foo = 0; X goto label4; X label3: X $foo = 4; X goto label4; X} Xgoto label1; X X$foo = 3; X Xlabel2: Xprint "#1\t:$foo: == 2\n"; Xif ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";} Xgoto label3; X Xlabel4: Xprint "#2\t:$foo: == 4\n"; Xif ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} X X$x = `./perl -e 'goto foo;' 2>&1`; Xprint "#3\t/label/ in :$x"; Xif ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} !STUFFY!FUNK! echo Extracting client sed >client <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X$pat = 'S n C4 x8'; X$inet = 2; X$echo = 7; X$smtp = 25; X$nntp = 119; X$test = 2345; X X$SIG{'INT'} = 'dokill'; X X$this = pack($pat,$inet,0, 128,149,13,43); X$that = pack($pat,$inet,$test,127,0,0,1); X Xif (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } Xif (bind(S,$this)) { print "bind ok\n"; } else { die $!; } Xif (connect(S,$that)) { print "connect ok\n"; } else { die $!; } X Xselect(S); $| = 1; select(stdout); X Xif ($child = fork) { X while (<>) { X print S; X } X sleep 3; X do dokill(); X} Xelse { X while () { X print; X } X} X Xsub dokill { kill 9,$child if $child; } !STUFFY!FUNK! echo Extracting eg/muck.man sed >eg/muck.man <<'!STUFFY!FUNK!' -e 's/X//' X.\" $Header: muck.man,v 3.0 89/10/18 15:14:55 lwall Locked $ X.TH MUCK 1 "10 Jan 1989" X.SH NAME Xmuck \- make usage checker X.SH SYNOPSIS X.B muck X[options] X.SH DESCRIPTION X.I muck Xlooks at your current makefile and complains if you've left out any dependencies Xbetween .o and .h files. XIt also complains about extraneous dependencies. X.PP XYou can use the -f FILENAME option to specify an alternate name for your Xmakefile. XThe -v option is a little more verbose about what muck is mucking around Xwith at the moment. X.SH SEE ALSO Xmake(1) X.SH BUGS XOnly knows about .h, .c and .o files. !STUFFY!FUNK! echo Extracting lib/dumpvar.pl sed >lib/dumpvar.pl <<'!STUFFY!FUNK!' -e 's/X//' Xpackage dumpvar; X Xsub main'dumpvar { X ($package) = @_; X local(*stab) = eval("*_$package"); X while (($key,$val) = each(%stab)) { X { X local(*entry) = $val; X if (defined $entry) { X print "\$$key = '$entry'\n"; X } X if (defined @entry) { X print "\@$key = (\n"; X foreach $num ($[ .. $#entry) { X print " $num\t'",$entry[$num],"'\n"; X } X print ")\n"; X } X if ($key ne "_$package" && defined %entry) { X print "\%$key = (\n"; X foreach $key (sort keys(%entry)) { X print " $key\t'",$entry{$key},"'\n"; X } X print ")\n"; X } X } X } X} !STUFFY!FUNK! echo Extracting server sed >server <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X$pat = 'S n C4 x8'; X$inet = 2; X$echo = 7; X$smtp = 25; X$nntp = 119; X X$this = pack($pat,$inet,2345, 0,0,0,0); Xselect(NS); $| = 1; select(stdout); X Xif (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } Xif (bind(S,$this)) { print "bind ok\n"; } else { die $!; } Xif (listen(S,5)) { print "listen ok\n"; } else { die $!; } Xfor (;;) { X print "Listening again\n"; X if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; } X X @ary = unpack($pat,$addr); X $, = ' '; X print @ary; print "\n"; X X while () { X print; X print NS; X } X} !STUFFY!FUNK! echo Extracting t/op.flip sed >t/op.flip <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.flip,v 3.0 89/10/18 15:29:07 lwall Locked $ X Xprint "1..8\n"; X X@a = (1,2,3,4,5,6,7,8,9,10,11,12); X Xwhile ($_ = shift(a)) { X if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; } X $y .= /1/../2/; X} X Xif ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";} X Xif ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} X X@a = ('a','b','c','d','e','f','g'); X Xopen(of,'../Makefile'); Xwhile () { X (3 .. 5) && $foo .= $_; X} X$x = ($foo =~ y/\n/\n/); X Xif ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} !STUFFY!FUNK! echo Extracting eg/dus sed >eg/dus <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: dus,v 3.0 89/10/18 15:13:43 lwall Locked $ X X# This script does a du -s on any directories in the current directory that X# are not mount points for another filesystem. X X($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, X $blksize,$blocks) = stat('.'); X Xopen(ls,'ls -F1|'); X Xwhile () { X chop; X next unless s|/$||; X ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, X $blksize,$blocks) = stat($_); X next unless $dev == $mydev; X push(@ary,$_); X} X Xexec 'du', '-s', @ary; !STUFFY!FUNK! echo Extracting t/op.chop sed >t/op.chop <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.chop,v 3.0 89/10/18 15:28:19 lwall Locked $ X Xprint "1..4\n"; X X# optimized X X$_ = 'abc'; X$c = do foo(); Xif ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";} X X# unoptimized X X$_ = 'abc'; X$c = chop($_); Xif ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";} X Xsub foo { X chop; X} X X@foo = ("hi \n","there\n","!\n"); X@bar = @foo; Xchop(@bar); Xprint join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n"; X X$foo = "\n"; Xchop($foo,@foo); Xprint join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n"; !STUFFY!FUNK! echo Extracting gettest sed >gettest <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X while (($name,$aliases,$addrtype,$length,@addrs) = gethostent) { X print $name,' ',$aliases, X sprintf(" %d.%d.%d.%d\n",unpack('CCCC',$addrs[0])); X last if $i++ > 50; X } X ; X while (($name,$aliases,$addrtype,$net) = getnetent) { X print "$name $aliases $addrtype ",sprintf("%08lx",$net),"\n"; X } X ; X while (($name,$aliases,$proto) = getprotoent) { X print "$name $aliases $proto\n"; X } X ; X while (($name,$aliases,$port,$proto) = getservent) { X print "$name $aliases $port $proto\n"; X } X !STUFFY!FUNK! echo Extracting t/io.dup sed >t/io.dup <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: io.dup,v 3.0 89/10/18 15:26:15 lwall Locked $ X Xprint "1..6\n"; X Xprint "ok 1\n"; X Xopen(dupout,">&STDOUT"); Xopen(duperr,">&STDERR"); X Xopen(STDOUT,">Io.dup") || die "Can't open stdout"; Xopen(STDERR,">&STDOUT") || die "Can't open stderr"; X Xselect(STDERR); $| = 1; Xselect(STDOUT); $| = 1; X Xprint STDOUT "ok 2\n"; Xprint STDERR "ok 3\n"; Xsystem 'echo ok 4'; Xsystem 'echo ok 5 1>&2'; X Xclose(STDOUT); Xclose(STDERR); X Xopen(STDOUT,">&dupout"); Xopen(STDERR,">&duperr"); X Xsystem 'cat Io.dup'; Xunlink 'Io.dup'; X Xprint STDOUT "ok 6\n"; !STUFFY!FUNK! echo Extracting t/op.sort sed >t/op.sort <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.sort,v 3.0 89/10/18 15:31:19 lwall Locked $ X Xprint "1..3\n"; X Xsub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } X X@harry = ('dog','cat','x','Cain','Abel'); X@george = ('gone','chased','yz','Punished','Axed'); X X$x = join('', sort @harry); Xprint ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); X X$x = join('', sort reverse @harry); Xprint ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); X X$x = join('', sort @george, 'to', @harry); Xprint ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n"); !STUFFY!FUNK! echo Extracting lib/abbrev.pl sed >lib/abbrev.pl <<'!STUFFY!FUNK!' -e 's/X//' X;# Usage: X;# %foo = (); X;# &abbrev(*foo,LIST); X;# ... X;# $long = $foo{$short}; X Xpackage abbrev; X Xsub main'abbrev { X local(*domain) = @_; X shift(@_); X @cmp = @_; X foreach $name (@_) { X @extra = split(//,$name); X $abbrev = shift(@extra); X $len = 1; X foreach $cmp (@cmp) { X next if $cmp eq $name; X while (substr($cmp,0,$len) eq $abbrev) { X $abbrev .= shift(@extra); X ++$len; X } X } X $domain{$abbrev} = $name; X while ($#extra >= 0) { X $abbrev .= shift(@extra); X $domain{$abbrev} = $name; X } X } X} X X1; !STUFFY!FUNK! echo Extracting t/cmd.elsif sed >t/cmd.elsif <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: cmd.elsif,v 3.0 89/10/18 15:24:38 lwall Locked $ X Xsub foo { X if ($_[0] == 1) { X 1; X } X elsif ($_[0] == 2) { X 2; X } X elsif ($_[0] == 3) { X 3; X } X else { X 4; X } X} X Xprint "1..4\n"; X Xif (($x = do foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";} Xif (($x = do foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";} Xif (($x = do foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";} Xif (($x = do foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";} !STUFFY!FUNK! echo Extracting t/comp.script sed >t/comp.script <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: comp.script,v 3.0 89/10/18 15:25:55 lwall Locked $ X Xprint "1..3\n"; X X$x = `./perl -e 'print "ok\n";'`; X Xif ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";} X Xopen(try,">Comp.script") || (die "Can't open temp file."); Xprint try 'print "ok\n";'; print try "\n"; Xclose try; X X$x = `./perl Comp.script`; X Xif ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";} X X$x = `./perl eg/findtar <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: findtar,v 3.0 89/10/18 15:13:52 lwall Locked $ X X# findtar takes find-style arguments and spits out a tarfile on stdout. X# It won't work unless your find supports -ls and your tar the I flag. X X$args = join(' ',@ARGV); Xopen(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; X Xopen(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; X Xwhile () { X @x = split(' '); X if ($x[2] =~ /^d/) { print tar '-d ';} X print tar $x[10],"\n"; X} !STUFFY!FUNK! echo Extracting t/comp.decl sed >t/comp.decl <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: comp.decl,v 3.0 89/10/18 15:25:25 lwall Locked $ X X# check to see if subroutine declarations work everwhere X Xsub one { X print "ok 1\n"; X} Xformat one = Xok 5 X. X Xprint "1..7\n"; X Xdo one(); Xdo two(); X Xsub two { X print "ok 2\n"; X} Xformat two = X@<<< X$foo X. X Xif ($x eq $x) { X sub three { X print "ok 3\n"; X } X do three(); X} X Xdo four(); X$~ = 'one'; Xwrite; X$~ = 'two'; X$foo = "ok 6"; Xwrite; X$~ = 'three'; Xwrite; X Xformat three = Xok 7 X. X Xsub four { X print "ok 4\n"; X} !STUFFY!FUNK! echo Extracting t/op.append sed >t/op.append <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.append,v 3.0 89/10/18 15:26:51 lwall Locked $ X Xprint "1..3\n"; X X$a = 'ab' . 'c'; # compile time X$b = 'def'; X X$c = $a . $b; Xprint "#1\t:$c: eq :abcdef:\n"; Xif ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";} X X$c .= 'xyz'; Xprint "#2\t:$c: eq :abcdefxyz:\n"; Xif ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";} X X$_ = $a; X$_ .= $b; Xprint "#3\t:$_: eq :abcdef:\n"; Xif ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} !STUFFY!FUNK! echo Extracting eg/down sed >eg/down <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X$| = 1; Xif ($#ARGV >= 0) { X $cmd = join(' ',@ARGV); X} Xelse { X print "Command: "; X $cmd = ; X chop($cmd); X while ($cmd =~ s/\\$//) { X print "+ "; X $cmd .= ; X chop($cmd); X } X} X$cwd = `pwd`; chop($cwd); X Xopen(FIND,'find . -type d -print|') || die "Can't run find"; X Xwhile () { X chop; X unless (chdir $_) { X print stderr "Can't cd to $_\n"; X next; X } X print "\t--> ",$_,"\n"; X system $cmd; X chdir $cwd; X} !STUFFY!FUNK! echo Extracting t/op.glob sed >t/op.glob <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.glob,v 3.0 89/10/18 15:29:19 lwall Locked $ X Xprint "1..4\n"; X X@ops = ; X$list = join(' ',@ops); X Xchop($otherway = `echo op.*`); X Xprint $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n"; X Xprint $/ eq "\n" ? "ok 2\n" : "not ok 2\n"; X Xwhile () { X $not = "not " unless $_ eq shift @ops; X $not = "not at all " if $/ eq "\0"; X} Xprint "${not}ok 3\n"; X Xprint $/ eq "\n" ? "ok 4\n" : "not ok 4\n"; !STUFFY!FUNK! echo Extracting eg/who sed >eg/who <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X# This assumes your /etc/utmp file looks like ours Xopen(utmp,'/etc/utmp'); X@mo = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); Xwhile (read(utmp,$utmp,36)) { X ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); X if ($name) { X $host = "($host)" if $host; X ($sec,$min,$hour,$mday,$mon) = localtime($time); X printf "%-9s%-8s%s %2d %02d:%02d %s\n", X $name,$line,$mo[$mon],$mday,$hour,$min,$host; X } X} !STUFFY!FUNK! echo Extracting t/op.mkdir sed >t/op.mkdir <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.mkdir,v 3.0 89/10/18 15:30:05 lwall Locked $ X Xprint "1..7\n"; X X`rm -rf blurfl`; X Xprint (mkdir('blurfl',0666) ? "ok 1\n" : "not ok 1\n"); Xprint (mkdir('blurfl',0666) ? "not ok 2\n" : "ok 2\n"); Xprint ($! == 17 ? "ok 3\n" : "not ok 3\n"); Xprint (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); Xprint (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); Xprint (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); Xprint ($! == 2 ? "ok 7\n" : "not ok 7\n"); !STUFFY!FUNK! echo Extracting t/io.print sed >t/io.print <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: io.print,v 3.0 89/10/18 15:26:36 lwall Locked $ X Xprint "1..16\n"; X X$foo = 'STDOUT'; Xprint $foo "ok 1\n"; X Xprint "ok 2\n","ok 3\n","ok 4\n"; Xprint STDOUT "ok 5\n"; X Xopen(foo,">-"); Xprint foo "ok 6\n"; X Xprintf "ok %d\n",7; Xprintf("ok %d\n",8); X X@a = ("ok %d%c",9,ord("\n")); Xprintf @a; X X$a[1] = 10; Xprintf STDOUT @a; X X$, = ' '; X$\ = "\n"; X Xprint "ok","11"; X X@x = ("ok","12\nok","13\nok"); X@y = ("15\nok","16"); Xprint @x,"14\nok",@y; !STUFFY!FUNK! echo Extracting t/io.inplace sed >t/io.inplace <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl -i.bak X X# $Header: io.inplace,v 3.0 89/10/18 15:26:25 lwall Locked $ X Xprint "1..2\n"; X X@ARGV = ('.a','.b','.c'); X`echo foo | tee .a .b .c`; Xwhile (<>) { X s/foo/bar/; X} Xcontinue { X print; X} X Xif (`cat .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";} Xif (`cat .a.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";} X Xunlink '.a', '.b', '.c', '.a.bak', '.b.bak', '.c.bak'; !STUFFY!FUNK! echo Extracting eg/van/vanexp sed >eg/van/vanexp <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: vanexp,v 3.0 89/10/18 15:16:41 lwall Locked $ X X# This is for running from a find at night to expire old .deleteds X X$can = $ARGV[0]; X Xexit 1 unless $can =~ /.deleted$/; X X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, X $blksize,$blocks) = stat($can); X Xexit 0 unless $size; X Xif (time - $mtime > 2 * 24 * 60 * 60) { X `/bin/rm -rf $can`; X} Xelse { X `find $can -ctime +2 -exec rm -f {} \;`; X} !STUFFY!FUNK! echo Extracting t/op.read sed >t/op.read <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.read,v 3.0 89/10/18 15:30:58 lwall Locked $ X Xprint "1..4\n"; X X Xopen(FOO,'op.read') || open(FOO,'t/op.read') || die "Can't open op.read"; Xseek(FOO,4,0); X$got = read(FOO,$buf,4); X Xprint ($got == 4 ? "ok 1\n" : "not ok 1\n"); Xprint ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n"); X Xseek(FOO,20000,0); X$got = read(FOO,$buf,4); X Xprint ($got == 0 ? "ok 3\n" : "not ok 3\n"); Xprint ($buf eq "" ? "ok 4\n" : "not ok 4\n"); !STUFFY!FUNK! echo Extracting t/op.pack sed >t/op.pack <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.pack,v 3.0 89/10/18 15:30:39 lwall Locked $ X Xprint "1..3\n"; X X$format = "c2x5CCxsila6"; X@ary = (1,-100,127,128,32767,12345,123456,"abcdef"); X$foo = pack($format,@ary); X@ary2 = unpack($format,$foo); X Xprint ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); X X$out1=join(':',@ary); X$out2=join(':',@ary2); Xprint ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n"); X Xprint ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); !STUFFY!FUNK! echo Extracting eg/g/ged sed >eg/g/ged <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: ged,v 3.0 89/10/18 15:14:22 lwall Locked $ X X# Does inplace edits on a set of files on a set of machines. X# X# Typical invokation: X# X# ged vax+sun /etc/passwd X# s/Freddy/Freddie/; X# ^D X# X X$class = shift; X$files = join(' ',@ARGV); X Xdie "Usage: ged class files x2p/EXTERN.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: EXTERN.h,v 3.0 89/10/18 15:33:37 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: EXTERN.h,v $ X * Revision 3.0 89/10/18 15:33:37 lwall X * 3.0 baseline X * X */ X X#undef EXT X#define EXT extern X X#undef INIT X#define INIT(x) X X#undef DOINIT !STUFFY!FUNK! echo Extracting EXTERN.h sed >EXTERN.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: EXTERN.h,v 3.0 89/10/18 15:06:03 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: EXTERN.h,v $ X * Revision 3.0 89/10/18 15:06:03 lwall X * 3.0 baseline X * X */ X X#undef EXT X#define EXT extern X X#undef INIT X#define INIT(x) X X#undef DOINIT !STUFFY!FUNK! echo Extracting x2p/INTERN.h sed >x2p/INTERN.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: INTERN.h,v 3.0 89/10/18 15:33:45 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: INTERN.h,v $ X * Revision 3.0 89/10/18 15:33:45 lwall X * 3.0 baseline X * X */ X X#undef EXT X#define EXT X X#undef INIT X#define INIT(x) = x X X#define DOINIT !STUFFY!FUNK! echo Extracting INTERN.h sed >INTERN.h <<'!STUFFY!FUNK!' -e 's/X//' X/* $Header: INTERN.h,v 3.0 89/10/18 15:06:25 lwall Locked $ X * X * Copyright (c) 1989, Larry Wall X * X * You may distribute under the terms of the GNU General Public License X * as specified in the README file that comes with the perl 3.0 kit. X * X * $Log: INTERN.h,v $ X * Revision 3.0 89/10/18 15:06:25 lwall X * 3.0 baseline X * X */ X X#undef EXT X#define EXT X X#undef INIT X#define INIT(x) = x X X#define DOINIT !STUFFY!FUNK! echo Extracting t/op.int sed >t/op.int <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.int,v 3.0 89/10/18 15:29:33 lwall Locked $ X Xprint "1..4\n"; X X# compile time evaluation X Xif (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";} X Xif (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} X X# run time evaluation X X$x = 1.234; Xif (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} Xif (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} !STUFFY!FUNK! echo Extracting t/base.cond sed >t/base.cond <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: base.cond,v 3.0 89/10/18 15:24:11 lwall Locked $ X X# make sure conditional operators work X Xprint "1..4\n"; X X$x = '0'; X X$x eq $x && (print "ok 1\n"); X$x ne $x && (print "not ok 1\n"); X$x eq $x || (print "not ok 2\n"); X$x ne $x || (print "ok 2\n"); X X$x == $x && (print "ok 3\n"); X$x != $x && (print "not ok 3\n"); X$x == $x || (print "not ok 4\n"); X$x != $x || (print "ok 4\n"); !STUFFY!FUNK! echo Extracting perlsh sed >perlsh <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# Poor man's perl shell. X X# Simply type two carriage returns every time you want to evaluate. X# Note that it must be a complete perl statement--don't type double X# carriage return in the middle of a loop. X X$/ = ''; # set paragraph mode X$SHlinesep = "\n"; Xwhile ($SHcmd = <>) { X $/ = $SHlinesep; X eval $SHcmd; print $@ || "\n"; X $SHlinesep = $/; $/ = ''; X} !STUFFY!FUNK! echo Extracting eg/nih sed >eg/nih <<'!STUFFY!FUNK!' -e 's/X//' Xeval "exec /usr/bin/perl -Spi.bak $0 $*" X if $running_under_some_shell; X X# $Header: nih,v 3.0 89/10/18 15:15:12 lwall Locked $ X X# This script makes #! scripts directly executable on machines that don't X# support #!. It edits in place any scripts mentioned on the command line. X Xs|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| X if $. == 1; !STUFFY!FUNK! echo Extracting lib/importenv.pl sed >lib/importenv.pl <<'!STUFFY!FUNK!' -e 's/X//' X;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $ X X;# This file, when interpreted, pulls the environment into normal variables. X;# Usage: X;# do 'importenv.pl'; X;# or X;# #include X Xlocal($tmp,$key) = ''; X Xforeach $key (keys(ENV)) { X $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; X} Xeval $tmp; X X1; !STUFFY!FUNK! echo Extracting t/op.join sed >t/op.join <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.join,v 3.0 89/10/18 15:29:38 lwall Locked $ X Xprint "1..3\n"; X X@x = (1, 2, 3); Xif (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} X Xif (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} X Xif (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} !STUFFY!FUNK! echo Extracting t/io.pipe sed >t/io.pipe <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: io.pipe,v 3.0 89/10/18 15:26:30 lwall Locked $ X X$| = 1; Xprint "1..4\n"; X Xopen(PIPE, "|-") || (exec 'tr', '[A-Z]', '[a-z]'); Xprint PIPE "OK 1\n"; Xprint PIPE "ok 2\n"; Xclose PIPE; X Xif (open(PIPE, "-|")) { X while() { X print; X } X} Xelse { X print STDOUT "ok 3\n"; X exec 'echo', 'ok 4'; X} !STUFFY!FUNK! echo Extracting t/op.unshift sed >t/op.unshift <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.unshift,v 3.0 89/10/18 15:32:06 lwall Locked $ X Xprint "1..2\n"; X X@a = (1,2,3); X$cnt1 = unshift(a,0); X Xif (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";} X$cnt2 = unshift(a,3,2,1); Xif (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";} X X !STUFFY!FUNK! echo Extracting t/op.oct sed >t/op.oct <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.oct,v 3.0 89/10/18 15:30:15 lwall Locked $ X Xprint "1..3\n"; X Xif (oct('01234') == 01234) {print "ok 1\n";} else {print "not ok 1\n";} Xif (oct('0x1234') == 0x1234) {print "ok 2\n";} else {print "not ok 2\n";} Xif (hex('01234') == 0x1234) {print "ok 3\n";} else {print "not ok 3\n";} !STUFFY!FUNK! echo Extracting t/op.ord sed >t/op.ord <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.ord,v 3.0 89/10/18 15:30:29 lwall Locked $ X Xprint "1..2\n"; X X# compile time evaluation X Xif (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";} X X# run time evaluation X X$x = 'ABC'; Xif (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";} !STUFFY!FUNK! echo Extracting t/op.fork sed >t/op.fork <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.fork,v 3.0 89/10/18 15:29:12 lwall Locked $ X X$| = 1; Xprint "1..2\n"; X Xif ($cid = fork) { X sleep 2; X if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} X} Xelse { X $| = 1; X print "ok 1\n"; X sleep 10; X} !STUFFY!FUNK! echo Extracting t/base.if sed >t/base.if <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: base.if,v 3.0 89/10/18 15:24:17 lwall Locked $ X Xprint "1..2\n"; X X# first test to see if we can run the tests. X X$x = 'test'; Xif ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";} Xif ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";} !STUFFY!FUNK! echo Extracting t/base.pat sed >t/base.pat <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: base.pat,v 3.0 89/10/18 15:24:30 lwall Locked $ X Xprint "1..2\n"; X X# first test to see if we can run the tests. X X$_ = 'test'; Xif (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";} Xif (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";} !STUFFY!FUNK! echo Extracting t/op.cond sed >t/op.cond <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.cond,v 3.0 89/10/18 15:28:26 lwall Locked $ X Xprint "1..4\n"; X Xprint 1 ? "ok 1\n" : "not ok 1\n"; # compile time Xprint 0 ? "not ok 2\n" : "ok 2\n"; X X$x = 1; Xprint $x ? "ok 3\n" : "not ok 3\n"; # run time Xprint !$x ? "not ok 4\n" : "ok 4\n"; !STUFFY!FUNK! echo Extracting t/op.sprintf sed >t/op.sprintf <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: op.sprintf,v 3.0 89/10/18 15:31:28 lwall Locked $ X Xprint "1..1\n"; X X$x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999); Xif ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";} !STUFFY!FUNK! echo Extracting eg/rename sed >eg/rename <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X($op = shift) || die "Usage: rename perlexpr [filenames]\n"; Xif ($#ARGV < 0) { X @ARGV = ; X chop(@ARGV); X} Xfor (@ARGV) { X $was = $_; X eval $op; X die $@ if $@; X rename($was,$_) unless $was eq $_; X} !STUFFY!FUNK! echo Extracting eg/ADB sed >eg/ADB <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl X X# $Header: ADB,v 3.0 89/10/18 15:13:04 lwall Locked $ X X# This script is only useful when used in your crash directory. X X$num = shift; Xexec 'adb', '-k', "vmunix.$num", "vmcore.$num"; !STUFFY!FUNK! echo Extracting eg/rmfrom sed >eg/rmfrom <<'!STUFFY!FUNK!' -e 's/X//' X#!/usr/bin/perl -n X X# $Header: rmfrom,v 3.0 89/10/18 15:15:20 lwall Locked $ X X# A handy (but dangerous) script to put after a find ... -print. X Xchop; unlink; !STUFFY!FUNK! echo Extracting Wishlist sed >Wishlist <<'!STUFFY!FUNK!' -e 's/X//' Xctime to time support Xbetter format pictures Xpager? Xbuilt-in cpp Xperl to C translator Xmulti-threading !STUFFY!FUNK! echo "" echo "End of kit 24 (of 24)" cat /dev/null >kit24isdone run='' config='' for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24; do if test -f kit${iskit}isdone; then run="$run $iskit" else todo="$todo $iskit" fi done case $todo in '') echo "You have run all your kits. Please read README and then type Configure." chmod 755 Configure ;; *) echo "You have run$run." echo "You still need to run$todo." ;; esac : Someone might mail this, so... exit