perl 3.0 beta kit [22/23]

[Larry Wall]

#! /bin/sh

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

echo "This is perl 3.0 kit 22 (of 23).  If kit 22 is complete, the line"
echo '"'"End of kit 22 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg/g eg/scan eg/van eg lib t x2p 2>/dev/null
echo Extracting eg/scan/scan_df
sed >eg/scan/scan_df <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_df,v 2.0 88/06/05 00:17:56 root Exp $
X
X# This report points out filesystems that are in danger of overflowing.
X
X(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
X`df >newdf`;
Xopen(Df, 'olddf');
X
Xwhile (<Df>) {
X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
X    next if $fs =~ /:/;
X    next if $fs eq '';
X    $oldused{$fs} = $used;
X}
X
Xopen(Df, 'newdf') || die "scan_df: can't open newdf";
X
Xwhile (<Df>) {
X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
X    next if $fs =~ /:/;
X    next if $fs eq '';
X    $oldused = $oldused{$fs};
X    next if ($oldused == $used && $capacity < 99);	# inactive filesystem
X    if ($capacity >= 90) {
X#if defined(mc300) || defined(mc500) || defined(mc700)
X	$_ = substr($_,0,13) . '        ' . substr($_,13,1000);
X	$kbytes /= 2;		# translate blocks to K
X	$used /= 2;
X	$oldused /= 2;
X	$avail /= 2;
X#endif
X	$diff = int($used - $oldused);
X	if ($avail < $diff * 2) {	# mark specially if in danger
X	    $mounted_on .= ' *';
X	}
X	next if $diff < 50 && $mounted_on eq '/';
X	$fs =~ s|/dev/||;
X	if ($diff >= 0) {
X	    $diff = '(+' . $diff . ')';
X	}
X	else {
X	    $diff = '(' . $diff . ')';
X	}
X	printf "%-8s%8d%8d %-8s%8d%7s    %s\n",
X	    $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
X    }
X}
X
Xrename('newdf','olddf');
!STUFFY!FUNK!
echo Extracting t/op.undef
sed >t/op.undef <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
X
Xprint "1..21\n";
X
Xprint defined($a) ? "not ok 1\n" : "ok 1\n";
X
X$a = 1+1;
Xprint defined($a) ? "ok 2\n" : "not ok 2\n";
X
Xundef $a;
Xprint defined($a) ? "not ok 3\n" : "ok 3\n";
X
X$a = "hi";
Xprint defined($a) ? "ok 4\n" : "not ok 4\n";
X
X$a = $b;
Xprint defined($a) ? "not ok 5\n" : "ok 5\n";
X
X at ary = ("1arg");
X$a = pop(@ary);
Xprint defined($a) ? "ok 6\n" : "not ok 6\n";
X$a = pop(@ary);
Xprint defined($a) ? "not ok 7\n" : "ok 7\n";
X
X at ary = ("1arg");
X$a = shift(@ary);
Xprint defined($a) ? "ok 8\n" : "not ok 8\n";
X$a = shift(@ary);
Xprint defined($a) ? "not ok 9\n" : "ok 9\n";
X
X$ary{'foo'} = 'hi';
Xprint defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
Xprint defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
Xundef $ary{'foo'};
Xprint defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
X
Xprint defined(@ary) ? "ok 13\n" : "not ok 13\n";
Xprint defined(%ary) ? "ok 14\n" : "not ok 14\n";
Xundef @ary;
Xprint defined(@ary) ? "not ok 15\n" : "ok 15\n";
Xundef %ary;
Xprint defined(%ary) ? "not ok 16\n" : "ok 16\n";
X at ary = (1);
Xprint defined @ary ? "ok 17\n" : "not ok 18\n";
X%ary = (1,1);
Xprint defined %ary ? "ok 18\n" : "not ok 18\n";
X
Xsub foo { print "ok 19\n"; }
X
X&foo || print "not ok 19\n";
X
Xprint defined &foo ? "ok 20\n" : "not ok 20\n";
Xundef &foo;
Xprint defined(&foo) ? "not ok 21\n" : "ok 21\n";
!STUFFY!FUNK!
echo Extracting spat.h
sed >spat.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: spat.h,v 2.0 88/06/05 00:10:58 root Exp $
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:	spat.h,v $
X */
X
Xstruct scanpat {
X    SPAT	*spat_next;		/* list of all scanpats */
X    REGEXP	*spat_regexp;		/* compiled expression */
X    ARG		*spat_repl;		/* replacement string for subst */
X    ARG		*spat_runtime;		/* compile pattern at runtime */
X    STR		*spat_short;		/* for a fast bypass of execute() */
X    bool	spat_flags;
X    char	spat_slen;
X};
X
X#define SPAT_USED 1			/* spat has been used once already */
X#define SPAT_ONCE 2			/* use pattern only once per reset */
X#define SPAT_SCANFIRST 4		/* initial constant not anchored */
X#define SPAT_ALL 8			/* initial constant is whole pat */
X#define SPAT_SKIPWHITE 16		/* skip leading whitespace for split */
X#define SPAT_FOLD 32			/* case insensitivity */
X#define SPAT_CONST 64			/* subst replacement is constant */
X#define SPAT_KEEP 128			/* keep 1st runtime pattern forever */
X
XEXT SPAT *curspat;		/* what to do \ interps from */
XEXT SPAT *lastspat;		/* what to use in place of null pattern */
X
XEXT char *hint INIT(Nullch);	/* hint from cmd_exec to do_match et al */
X
X#define Nullspat Null(SPAT*)
!STUFFY!FUNK!
echo Extracting eg/scan/scan_last
sed >eg/scan/scan_last <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_last,v 2.0 88/06/05 00:17:58 root Exp $
X
X# This reports who was logged on at weird hours
X
X($dy, $mo, $lastdt) = split(/ +/,`date`);
X
Xopen(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
X
Xwhile (<Last>) {
X#if defined(mc300) || defined(mc500) || defined(mc700)
X    $_ = substr($_,0,19) . substr($_,23,100);
X#endif
X    next if /^$/;
X    (print),next if m|^/|;
X    $login  = substr($_,0,8);
X    $tty    = substr($_,10,7);
X    $from   = substr($_,19,15);
X    $day    = substr($_,36,3);
X    $mo     = substr($_,40,3);
X    $dt     = substr($_,44,2);
X    $hr     = substr($_,47,2);
X    $min    = substr($_,50,2);
X    $dash   = substr($_,53,1);
X    $tohr   = substr($_,55,2);
X    $tomin  = substr($_,58,2);
X    $durhr  = substr($_,63,2);
X    $durmin = substr($_,66,2);
X    
X    next unless $hr;
X    next if $login eq 'reboot  ';
X    next if $login eq 'shutdown';
X
X    if ($dt != $lastdt) {
X	if ($lastdt < $dt) {
X	    $seen += $dt - $lastdt;
X	}
X	else {
X	    $seen++;
X	}
X	$lastdt = $dt;
X    }
X
X    $inat = $hr + $min / 60;
X    if ($tohr =~ /^[a-z]/) {
X	$outat = 12;		# something innocuous
X    } else {
X	$outat = $tohr + $tomin / 60;
X    }
X
X  last if $seen + ($inat < 8) > 1;
X
X    if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
X	print;
X    }
X}
!STUFFY!FUNK!
echo Extracting x2p/hash.h
sed >x2p/hash.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.h,v 2.0 88/06/05 00:15:52 root Exp $
X *
X *    Copyright (c) 1989, Larry Wall
X *
X *    You may distribute under the terms of the GNU General Public License
X *    as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log:	hash.h,v $
X * Revision 2.0  88/06/05  00:15:52  root
X * Baseline version 2.0.
X * 
X */
X
X#define FILLPCT 60		/* don't make greater than 99 */
X
X#ifdef DOINIT
Xchar coeff[] = {
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
X		61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
X#else
Xextern char coeff[];
X#endif
X
Xtypedef struct hentry HENT;
X
Xstruct hentry {
X    HENT	*hent_next;
X    char	*hent_key;
X    STR		*hent_val;
X    int		hent_hash;
X};
X
Xstruct htbl {
X    HENT	**tbl_array;
X    int		tbl_max;
X    int		tbl_fill;
X    int		tbl_riter;	/* current root of iterator */
X    HENT	*tbl_eiter;	/* current entry of iterator */
X};
X
XSTR *hfetch();
Xbool hstore();
Xbool hdelete();
XHASH *hnew();
Xint hiterinit();
XHENT *hiternext();
Xchar *hiterkey();
XSTR *hiterval();
!STUFFY!FUNK!
echo Extracting t/comp.term
sed >t/comp.term <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: comp.term,v 2.0 88/06/05 00:12:52 root Exp $
X
X# tests that aren't important enough for base.term
X
Xprint "1..14\n";
X
X$x = "\\n";
Xprint "#1\t:$x: eq " . ':\n:' . "\n";
Xif ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$x = "#2\t:$x: eq :\\n:\n";
Xprint $x;
Xunless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
X
Xif (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
X
X$one = 'a';
X
Xif (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
Xif (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
Xif (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
Xif (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
Xif (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
Xif (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
Xif (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
X
Xif ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
X
X at foo = (1,2,3);
Xif ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
Xif ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
X$" = '::';
Xif ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
!STUFFY!FUNK!
echo Extracting hdef
sed >hdef <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
Xchop($cwd = `pwd`);
X
Xif (-f 'hdef.db') {
X    open(ODB,'hdef.db') || die "Can't open old database\n";
X}
X
Xopen(DB,">hdef.db.new") || die "Can't recreate database\n";
X
Xchdir '/usr/include' || die "Can't find /usr/include\n";
X
X at hfiles = <*.h>;
X at hhfiles = <sys/*.h machine/*.h net/*.h netinet/*.h netimp/*.h *if/*.h>;
Xif (-r $hhfiles[0]) {
X    push(@hfiles, at hhfiles);
X}
X
Xforeach $filename (@hfiles) {
X    $filename =~ s|^\./||;
X    open(FILE,$filename) || print stderr "Can't open $filename\n";
X    $seen{$filename} = 1;
X    print DB "$filename\n";
X    while (<FILE>) {
X	if (/^#\s*define\s+(\w+)/) {
X	    print DB "$1\n";
X	    next;
X	}
X	if (/^\s*struct\s+(\w+)\s+{/) {
X	    print DB "struct $1\n";
X	    next;
X	}
X	if (/^typedef\s+struct\s+\w+\s+{\s*$/) {
X	    while (<FILE>) {
X		last if /^}\s*\w+\s*;/;
X	    }
X	    print DB "$1\n" if /^}\s*(\w+)\s*;/;
X	    next;
X	}
X	if (/^typedef.*\W(\w+)\s*;/) {
X	    print DB "$1\n";
X	    next;
X	}
X    }
X    print DB "\n";
X}
Xclose FIND;
Xclose FILE;
X
Xif (-f 'hdef.db') {
X    $/ = '';		# paragraph mode
X    while (<ODB>) {
X	($filename) = split;
X	print DB $_ unless $seen{$filename};
X    }
X    close ODB;
X}
Xclose DB;
X
Xchdir $cwd;
Xrename('hdef.db','hdef.db.old');
Xrename('hdef.db.new','hdef.db');
!STUFFY!FUNK!
echo Extracting makedir.SH
sed >makedir.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase $CONFIG in
X'')
X    if test ! -f config.sh; then
X	ln ../config.sh . || \
X	ln ../../config.sh . || \
X	ln ../../../config.sh . || \
X	(echo "Can't find config.sh."; exit 1)
X    fi
X    . ./config.sh
X    ;;
Xesac
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xecho "Extracting makedir (with variable substitutions)"
X$spitshell >makedir <<!GROK!THIS!
X$startsh
X# $Header: makedir.SH,v 2.0 88/06/05 00:09:13 root Exp $
X# 
X# $Log:	makedir.SH,v $
X
Xexport PATH || (echo "OOPS, this isn't sh.  Desperation time.  I will feed myself to sh."; sh \$0; kill \$\$)
X
Xcase \$# in
X  0)
X    $echo "makedir pathname filenameflag"
X    exit 1
X    ;;
Xesac
X
X: guarantee one slash before 1st component
Xcase \$1 in
X  /*) ;;
X  *)  set ./\$1 \$2 ;;
Xesac
X
X: strip last component if it is to be a filename
Xcase X\$2 in
X  X1) set \`$echo \$1 | $sed 's:\(.*\)/[^/]*\$:\1:'\` ;;
X  *)  set \$1 ;;
Xesac
X
X: return reasonable status if nothing to be created
Xif $test -d "\$1" ; then
X    exit 0
Xfi
X
Xlist=''
Xwhile true ; do
X    case \$1 in
X    */*)
X	list="\$1 \$list"
X	set \`echo \$1 | $sed 's:\(.*\)/:\1 :'\`
X	;;
X    *)
X	break
X	;;
X    esac
Xdone
X
Xset \$list
X
Xfor dir do
X    $mkdir \$dir >/dev/null 2>&1
Xdone
X!GROK!THIS!
X$eunicefix makedir
Xchmod +x makedir
!STUFFY!FUNK!
echo Extracting eg/findcp
sed >eg/findcp <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: findcp,v 2.0 88/06/05 00:16:47 root Exp $
X
X# This is a wrapper around the find command that pretends find has a switch
X# of the form -cp host:destination.  It presumes your find implements -ls.
X# It uses tar to do the actual copy.  If your tar knows about the I switch
X# you may prefer to use findtar, since this one has to do the tar in batches.
X
Xsub copy {
X    `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
X}
X
X$sourcedir = $ARGV[0];
Xif ($sourcedir =~ /^\//) {
X    $ARGV[0] = '.';
X    unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
X}
X
X$args = join(' ', at ARGV);
Xif ($args =~ s/-cp *([^ ]+)/-ls/) {
X    $dest = $1;
X    if ($dest =~ /(.*):(.*)/) {
X	$desthost = $1;
X	$destdir = $2;
X    }
X    else {
X	die "Malformed destination--should be host:directory";
X    }
X}
Xelse {
X    die("No destination specified");
X}
X
Xopen(find,"find $args |") || die "Can't run find for you: $!";
X
Xwhile (<find>) {
X    @x = split(' ');
X    if ($x[2] =~ /^d/) { next;}
X    chop($filename = $x[10]);
X    if (length($list) > 5000) {
X	do copy();
X	$list = '';
X    }
X    else {
X	$list .= ' ';
X    }
X    $list .= $filename;
X}
X
Xif ($list) {
X    do copy();
X}
!STUFFY!FUNK!
echo Extracting t/base.lex
sed >t/base.lex <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: base.lex,v 2.0 88/06/05 00:12:06 root Exp $
X
Xprint "1..18\n";
X
X$ # this is the register <space>
X= 'x';
X
Xprint "#1	:$ : eq :x:\n";
Xif ($  eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$x = $#;	# this is the register $#
X
Xif ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
X
X$x = $#x;
X
Xif ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
X
X$x = '\\'; # ';
X
Xif (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
X
Xeval 'while (0) {
X    print "foo\n";
X}
X/^/ && (print "ok 5\n");
X';
X
Xeval '$foo{1} / 1;';
Xif (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
X
Xeval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
X
X$foo = int($foo * 100 + .5);
Xif ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7\n";}
X
Xprint <<'EOF';
Xok 8
XEOF
X
X$foo = 'ok 9';
Xprint <<EOF;
X$foo
XEOF
X
Xeval <<\EOE, print $@;
Xprint <<'EOF';
Xok 10
XEOF
X
X$foo = 'ok 11';
Xprint <<EOF;
X$foo
XEOF
XEOE
X
Xprint <<`EOS` . <<\EOF;
Xecho ok 12
XEOS
Xok 13
XEOF
X
Xprint qq/ok 14\n/;
Xprint qq(ok 15\n);
X
Xprint qq
Xok 16\n
X;
X
Xprint q<ok 17
X>;
X
Xprint <<;   # Yow!
Xok 18
X
X# previous line intentionally left blank.
!STUFFY!FUNK!
echo Extracting eg/scan/scan_sudo
sed >eg/scan/scan_sudo <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_sudo,v 2.0 88/06/05 00:18:01 root Exp $
X
X# Analyze the sudo log.
X
Xchdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
X
Xif (open(Oldsudo,'oldsudo')) {
X    $maxpos = <Oldsudo>;
X    close Oldsudo;
X}
Xelse {
X    $maxpos = 0;
X    `echo 0 >oldsudo`;
X}
X
Xunless (open(Sudo, '/usr/adm/sudo.log')) {
X    print "Somebody removed sudo.log!!!\n" if $maxpos;
X    exit 0;
X}
X
X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X   $blksize,$blocks) = stat(Sudo);
X
Xif ($size < $maxpos) {
X    $maxpos = 0;
X    print "Somebody reset sudo.log!!!\n";
X}
X
Xseek(Sudo,$maxpos,0);
X
Xwhile (<Sudo>) {
X    s/^.* :[ \t]+//;
X    s/ipcrm.*/ipcrm/;
X    s/kill.*/kill/;
X    unless ($seen{$_}++) {
X	push(@seen,$_);
X    }
X    $last = $_;
X}
X$max = tell(Sudo);
X
Xopen(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
Xwhile ($_ = pop(@seen)) {
X    print tmp $_;
X}
Xclose(tmp);
Xopen(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
Xwhile (<tmp>) {
X    print $seen{$_},":\t",$_;
X}
X
Xprint `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
!STUFFY!FUNK!
echo Extracting t/op.eval
sed >t/op.eval <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.eval,v 2.0 88/06/05 00:13:40 root Exp $
X
Xprint "1..10\n";
X
Xeval 'print "ok 1\n";';
X
Xif ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
X
Xeval "\$foo\n    = # this is a comment\n'ok 3';";
Xprint $foo,"\n";
X
Xeval "\$foo\n    = # this is a comment\n'ok 4\n';";
Xprint $foo;
X
Xprint eval '
X$foo =';		# this tests for a call through yyerror()
Xif ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
X
Xprint eval '$foo = /';	# this tests for a call through fatal()
Xif ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
X
Xprint eval '"ok 7\n";';
X
X# calculate a factorial with recursive evals
X
X$foo = 5;
X$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
X$ans = eval $fact;
Xif ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
X
X$foo = 5;
X$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
X$ans = eval $fact;
Xif ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
X
Xopen(try,'>Op.eval');
Xprint try 'print "ok 10\n"; unlink "Op.eval";',"\n";
Xclose try;
X
Xdo 'Op.eval'; print $@;
!STUFFY!FUNK!
echo Extracting x2p/str.h
sed >x2p/str.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: str.h,v 2.0 88/06/05 00:16:05 root Exp $
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:	str.h,v $
X * Revision 2.0  88/06/05  00:16:05  root
X * Baseline version 2.0.
X * 
X */
X
Xstruct string {
X    char *	str_ptr;	/* pointer to malloced string */
X    double	str_nval;	/* numeric value, if any */
X    int		str_len;	/* allocated size */
X    int		str_cur;	/* length of str_ptr as a C string */
X    union {
X	STR *str_next;		/* while free, link to next free str */
X    } str_link;
X    char	str_pok;	/* state of str_ptr */
X    char	str_nok;	/* state of str_nval */
X};
X
X#define Nullstr Null(STR*)
X
X/* the following macro updates any magic values this str is associated with */
X
X#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
X
XEXT STR **tmps_list;
XEXT long tmps_max INIT(-1);
X
Xchar *str_2ptr();
Xdouble str_2num();
XSTR *str_static();
XSTR *str_make();
XSTR *str_nmake();
Xchar *str_gets();
!STUFFY!FUNK!
echo Extracting t/op.each
sed >t/op.each <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.each,v 2.0.1.1 88/08/03 22:44:29 root Exp $
X
Xprint "1..3\n";
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$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 at keys = keys %h;
X at values = values %h;
X
Xif ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\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 2\n";} else {print "not ok 2\n";}
X
X at keys = ('blurfl', keys(%h), 'dyick');
Xif ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
!STUFFY!FUNK!
echo Extracting t/op.time
sed >t/op.time <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.time,v 2.0 88/06/05 00:14:58 root Exp $
X
Xprint "1..5\n";
X
X($beguser,$begsys) = times;
X
X$beg = time;
X
Xwhile (($now = time) == $beg) {}
X
Xif ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";}
X
Xfor ($i = 0; $i < 100000; $i++) {
X    ($nowuser, $nowsys) = times;
X    $i = 200000 if $nowuser > $beguser && $nowsys > $begsys;
X    last if time - $beg > 20;
X}
X
Xif ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";}
X
X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
X($xsec,$foo) = localtime($now);
X$localyday = $yday;
X
Xif ($sec != $xsec && $mday && $year)
X    {print "ok 3\n";}
Xelse
X    {print "not ok 3\n";}
X
X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
X($xsec,$foo) = localtime($now);
X
Xif ($sec != $xsec && $mday && $year)
X    {print "ok 4\n";}
Xelse
X    {print "not ok 4\n";}
X
Xif (index(" :0:1:-1:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0)
X    {print "ok 5\n";}
Xelse
X    {print "not ok 5\n";}
!STUFFY!FUNK!
echo Extracting t/op.do
sed >t/op.do <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.do,v 2.0 88/06/05 00:13:36 root Exp $
X
Xsub foo1
X{
X    print $_[0];
X    'value';
X}
X
Xsub foo2
X{
X    shift(_);
X    print $_[0];
X    $x = 'value';
X    $x;
X}
X
Xprint "1..15\n";
X
X$_[0] = "not ok 1\n";
X$result = do foo1("ok 1\n");
Xprint "#2\t:$result: eq :value:\n";
Xif ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; }
Xif ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; }
X
X$_[0] = "not ok 4\n";
X$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n");
Xprint "#5\t:$result: eq :value:\n";
Xif ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; }
Xif ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; }
X
X$result = do{print "ok 7\n"; 'value';};
Xprint "#8\t:$result: eq :value:\n";
Xif ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
X
Xsub blather {
X    print @_;
X}
X
Xdo blather("ok 9\n","ok 10\n");
X at x = ("ok 11\n", "ok 12\n");
X at y = ("ok 14\n", "ok 15\n");
Xdo blather(@x,"ok 13\n", at y);
!STUFFY!FUNK!
echo Extracting t/cmd.for
sed >t/cmd.for <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.for,v 2.0 88/06/05 00:12:19 root Exp $
X
Xprint "1..7\n";
X
Xfor ($i = 0; $i <= 10; $i++) {
X    $x[$i] = $i;
X}
X$y = $x[10];
Xprint "#1	:$y: eq :10:\n";
X$y = join(' ', @x);
Xprint "#1	:$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n";
Xif (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') {
X	print "ok 1\n";
X} else {
X	print "not ok 1\n";
X}
X
X$i = $c = 0;
Xfor (;;) {
X	$c++;
X	last if $i++ > 10;
X}
Xif ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
X
X$foo = 3210;
X at ary = (1,2,3,4,5);
Xforeach $foo (@ary) {
X	$foo *= 2;
X}
Xif (join('', at ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
X
Xfor (@ary) {
X    s/(.*)/ok $1\n/;
X}
X
Xprint $ary[1];
X
X# test for internal scratch array generation
X# this also tests that $foo was restored to 3210 after test 3
Xfor (split(' ','a b c d e')) {
X	$foo .= $_;
X}
Xif ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
X
Xforeach $foo (("ok 6\n","ok 7\n")) {
X	print $foo;
X}
!STUFFY!FUNK!
echo Extracting t/op.magic
sed >t/op.magic <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.magic,v 2.0 88/06/05 00:14:11 root Exp $
X
X$| = 1;		# command buffering
X
Xprint "1..5\n";
X
Xeval '$ENV{"foo"} = "hi there";';	# check that ENV is inited inside eval
Xif (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
X
X$! = 0;
Xopen(foo,'ajslkdfpqjsjfkslkjdflksd');
Xif ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";}
X
X# the next tests are embedded inside system simply because sh spits out
X# a newline onto stderr when a child process kills itself with SIGINT.
X
Xsystem './perl',
X'-e', '$| = 1;		# command buffering',
X
X'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;',
X'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";',
X'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
X
X'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
X
X at val1 = @ENV{keys(%ENV)};	# can we slice ENV?
X at val2 = values(%ENV);
X
Xprint join(':', at val1) eq join(':', at val2) ? "ok 5\n" : "not ok 5\n";
!STUFFY!FUNK!
echo Extracting t/op.repeat
sed >t/op.repeat <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.repeat,v 2.0 88/06/05 00:14:31 root Exp $
X
Xprint "1..11\n";
X
X# compile time
X
Xif ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
Xif ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
Xif ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
X
Xif ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
X
X# run time
X
X$a = '-';
Xif ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
Xif ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
Xif ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
X
X$a = 'ab';
Xif ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
X
X$a = 'xyz';
X$a x= 2;
Xif ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
X$a x= 1;
Xif ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
X$a x= 0;
Xif ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
X
!STUFFY!FUNK!
echo Extracting t/io.argv
sed >t/io.argv <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: io.argv,v 2.0 88/06/05 00:12:55 root Exp $
X
Xprint "1..5\n";
X
Xopen(try, '>Io.argv.tmp') || (die "Can't open temp file.");
Xprint try "a line\n";
Xclose try;
X
X$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
X
Xif ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";}
X
X$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`;
X
Xif ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
X
X$x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
X
Xif ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3\n";}
X
X at ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp');
Xwhile (<>) {
X    $y .= $. . $_;
X    if (eof()) {
X	if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
X    }
X}
X
Xif ($y eq "1a line\n2a line\n3a line\n")
X    {print "ok 5\n";}
Xelse
X    {print "not ok 5\n";}
X
X`/bin/rm -f Io.argv.tmp`;
!STUFFY!FUNK!
echo Extracting regexp.h
sed >regexp.h <<'!STUFFY!FUNK!' -e 's/X//'
X/*
X * Definitions etc. for regexp(3) routines.
X *
X * Caveat:  this is V8 regexp(3) [actually, a reimplementation thereof],
X * not the System V one.
X */
X
X/* $Header: regexp.h,v 2.0 88/06/05 00:10:53 root Exp $
X *
X * $Log:	regexp.h,v $
X */
X
X#define NSUBEXP  10
X
Xtypedef struct regexp {
X	char *startp[NSUBEXP];
X	char *endp[NSUBEXP];
X	STR *regstart;		/* Internal use only. */
X	char *regstclass;
X	STR *regmust;		/* Internal use only. */
X	int regback;		/* Can regmust locate first try? */
X	char *precomp;		/* pre-compilation regular expression */
X	char *subbase;		/* saved string so \digit works forever */
X	char reganch;		/* Internal use only. */
X	char do_folding;	/* do case-insensitive match? */
X	char lastparen;		/* last paren matched */
X	char nparens;		/* number of parentheses */
X	char program[1];	/* Unwarranted chumminess with compiler. */
X} regexp;
X
Xregexp *regcomp();
Xint regexec();
!STUFFY!FUNK!
echo Extracting eg/changes
sed >eg/changes <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: changes,v 2.0 88/06/05 00:16:41 root Exp $
X
X($dir, $days) = @ARGV;
X$dir = '/' if $dir eq '';
X$days = '14' if $days eq '';
X
X# Masscomps do things differently from Suns
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
Xopen(Find, "find $dir -mtime -$days -print |") ||
X	die "changes: can't run find";
X#else
Xopen(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
X	die "changes: can't run find";
X#endif
X
Xwhile (<Find>) {
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
X    $x = `/bin/ls -ild $_`;
X    $_ = $x;
X    ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
X      = split(' ');
X#else
X    ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
X      = split(' ');
X#endif
X
X    printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
X	    $perm,$links,$owner,$group,$size,$month,$day,$name);
X}
X
!STUFFY!FUNK!
echo Extracting eg/myrup
sed >eg/myrup <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: myrup,v 2.0 88/06/05 00:16:51 root Exp $
X
X# This was a customization of ruptime requested by someone here who wanted
X# to be able to find the least loaded machine easily.  It uses the
X# /etc/ghosts file that's defined for gsh and gcp to prune down the
X# number of entries to those hosts we have administrative control over.
X
Xprint "node    load (u)\n------- --------\n";
X
Xopen(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
Xline: while (<ghosts>) {
X    next line if /^#/;
X    next line if /^$/;
X    next line if /=/;
X    ($host) = split;
X    $wanted{$host} = 1;
X}
X
Xopen(ruptime,'ruptime|') || die "Can't run ruptime: $!";
Xopen(sort,'|sort +1n');
X
Xwhile (<ruptime>) {
X    ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
X    if ($wanted{$host} && $upness eq 'up') {
X	printf sort "%s\t%s (%d)\n", $host, $load, $users;
X    }
X}
!STUFFY!FUNK!
echo Extracting t/op.regexp
sed >t/op.regexp <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.regexp,v 2.0 88/06/05 00:14:27 root Exp $
X
Xopen(TESTS,'re_tests') || open(TESTS,'t/re_tests') || die "Can't open re_tests";
Xwhile (<TESTS>) { }
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 (<TESTS>) {
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 x2p/handy.h
sed >x2p/handy.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: handy.h,v 2.0 88/06/05 00:15:47 root Exp $
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 2.0  88/06/05  00:15:47  root
X * Baseline version 2.0.
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 2.0 88/06/05 00:16:10 root Exp $
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 2.0  88/06/05  00:16:10  root
X * Baseline version 2.0.
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 eg/g/ghosts
sed >eg/g/ghosts <<'!STUFFY!FUNK!' -e 's/X//'
X# This first section gives alternate sets defined in terms of the sets given
X# by the second section.  The order is important--all references must be
X# forward references.
X
XNnd=sun-nd
Xall=sun+mc+vax
Xbaseline=sun+mc
Xsun=sun2+sun3
Xvax=750+8600
Xpep=manny+moe+jack
X
X# This second section defines the basic sets.  Each host should have a line
X# that specifies which sets it is a member of.  Extra sets should be separated
X# by white space.  (The first section isn't strictly necessary, since all sets
X# could be defined in the second section, but then it wouldn't be so readable.)
X
Xbasvax	8600	src
Xcdb0	sun3		sys
Xcdb1	sun3		sys
Xcdb2	sun3		sys
Xchief	sun3	src
Xtis0	sun3
Xmanny	sun3		sys
Xmoe	sun3		sys
Xjack	sun3		sys
Xdisney	sun3		sys
Xhuey	sun3		nd
Xdewey	sun3		nd
Xlouie	sun3		nd
Xbizet	sun2	src	sys
Xgif0	mc	src
Xmc0	mc
Xdtv0	mc
!STUFFY!FUNK!
echo Extracting t/base.term
sed >t/base.term <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: base.term,v 2.0 88/06/05 00:12:13 root Exp $
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 (<try> eq '') {print "ok 5\n";} else {print "not ok 5\n";}
X
Xopen(try, "../Makefile") || (die "Can't open ../Makefile.");
Xif (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
!STUFFY!FUNK!
echo Extracting t/op.vec
sed >t/op.vec <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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 t/comp.multiline
sed >t/comp.multiline <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: comp.multiline,v 2.0 88/06/05 00:12:44 root Exp $
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 (<try>) {
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 eg/van/empty
sed >eg/van/empty <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: empty,v 2.0 88/06/05 00:17:39 root Exp $
X
X# This script empties a trashcan.
X
X$recursive = shift if $ARGV[0] eq '-r';
X
X at 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(' ', at _));
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 2.0 88/06/05 00:12:37 root Exp $
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 <Comp.cpp.inc>\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 t/op.write
sed >t/op.write <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.stat,v 2.0.1.1 88/08/03 22:46:11 root Exp $
X
Xprint "1..1\n";
X
Xformat OUT =
Xthe quick brown @<<
X$fox
Xjumped
X@*
X$multiline
X^<<<<<<<<<
X$foo
X^<<<<<<<<<
X$foo
X^<<<<<<...
X$foo
Xnow @<<the@>>>> for all@|||||men to come @<<<<
X'i' . 's', "time\n", $good, 'to'
X.
X
Xopen(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp";
X
X$fox = 'foxiness';
X$good = 'good';
X$multiline = "forescore\nand\nseven years\n";
X$foo = 'when in the course of human events it becomes necessary';
Xwrite(OUT);
Xclose OUT;
X
X$right =
X"the quick brown fox
Xjumped
Xforescore
Xand
Xseven years
Xwhen in
Xthe course
Xof huma...
Xnow is the time for all good men to come to\n";
X
Xif (`cat Op.write.tmp` eq $right)
X    { print "ok 1\n"; unlink 'Op.write.tmp'; }
Xelse
X    { print "not ok 1\n"; }
!STUFFY!FUNK!
echo Extracting t/op.local
sed >t/op.local <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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, at 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 at b = "ok 16\n";
X at c = "ok 17\n";
X$d{''} = "ok 18\n";
X
Xprint do foo2("ok 11\n","ok 12\n");
X
Xprint $a, at b, at c,%d,$x,$y;
!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 2.0 88/06/05 00:17:51 root Exp $
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 (<Ps>) {
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 (<Ps>) {
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.delete
sed >t/op.delete <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.delete,v 2.0 88/06/05 00:13:30 root Exp $
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 t/op.index
sed >t/op.index <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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 form.h
sed >form.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: form.h,v 2.0.1.1 88/11/22 01:08:49 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 */
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
X#define Nullfcmd Null(FCMD*)
X
XEXT char *chopset INIT(" \n-");
!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/cmd.mod
sed >t/cmd.mod <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.mod,v 2.0 88/06/05 00:12:23 root Exp $
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(' ', at 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 <foo>;
Xprint $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n";
!STUFFY!FUNK!
echo Extracting t/op.exp
sed >t/op.exp <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.exp,v 2.0 88/06/05 00:13:48 root Exp $
X
Xprint "1..6\n";
X
X# compile time evaluation
X
X$s = sqrt(2);
Xif (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$s = exp(1);
Xif (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";}
X
Xif (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
X
X# run time evaluation
X
X$x1 = 1;
X$x2 = 2;
X$s = sqrt($x2);
Xif (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";}
X
X$s = exp($x1);
Xif (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";}
X
Xif (exp(log($x1)) == 1) {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 2.0.1.1 88/11/19 00:32:02 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 */
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 t/op.range
sed >t/op.range <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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 at foo = (1,2,3,4,5,6,7,8,9);
X at foo[2..4] = ('c','d','e');
X
Xprint join(':', at foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
X
X at bar[2..4] = ('c','d','e');
Xprint join(':', at bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
X
X($a, at bcd[0..2],$e) = ('a','b','c','d','e');
Xprint join(':',$a, at 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 array.h
sed >array.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: array.h,v 2.0 88/06/05 00:08:21 root Exp $
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 */
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 lib/stat.pl
sed >lib/stat.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $
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 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 (<S>) {
X	print;
X    }
X}
X
Xsub dokill { kill 9,$child if $child; }
!STUFFY!FUNK!
echo Extracting t/op.goto
sed >t/op.goto <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: op.goto,v 2.0 88/06/05 00:13:58 root Exp $
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 t/op.read
sed >t/op.read <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header$
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 ""
echo "End of kit 22 (of 23)"
cat /dev/null >kit22isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23; 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