lwall@netlabs.com (Larry Wall) (04/19/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 53
Archive-name: perl/part35
[There are 36 kits for perl version 4.0.]
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh. When all 36 kits have been run, read README.
echo "This is perl 4.0 kit 35 (of 36). If kit 35 is complete, the line"
echo '"'"End of kit 35 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg eg/g eg/scan eg/sysvipc eg/van h2pl hints lib msdos msdos/eg os2 t t/base t/cmd t/comp t/io t/op x2p 2>/dev/null
echo Extracting eg/findcp
sed >eg/findcp <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: findcp,v 4.0 91/03/20 01:09:37 lwall Locked $
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(' ',@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/op/push.t
sed >t/op/push.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $
X
X@tests = split(/\n/, <<EOF);
X0 3, 0 1 2, 3 4 5 6 7
X0 0 a b c, , a b c 0 1 2 3 4 5 6 7
X8 0 a b c, , 0 1 2 3 4 5 6 7 a b c
X7 0 6.5, , 0 1 2 3 4 5 6 6.5 7
X1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7
X0 1 a, 0, a 1 2 3 4 5 6 7
X1 6 x y z, 1 2 3 4 5 6, 0 x y z 7
X0 7 x y z, 0 1 2 3 4 5 6, x y z 7
X1 7 x y z, 1 2 3 4 5 6 7, 0 x y z
X4, 4 5 6 7, 0 1 2 3
X-4, 4 5 6 7, 0 1 2 3
XEOF
X
Xprint "1..", 2 + @tests, "\n";
Xdie "blech" unless @tests;
X
X@x = (1,2,3);
Xpush(@x,@x);
Xif (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
Xpush(x,4);
Xif (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
X
X$test = 3;
Xforeach $line (@tests) {
X ($list,$get,$leave) = split(/,\t*/,$line);
X @list = split(' ',$list);
X @get = split(' ',$get);
X @leave = split(' ',$leave);
X @x = (0,1,2,3,4,5,6,7);
X @got = splice(@x,@list);
X if (join(':',@got) eq join(':',@get) &&
X join(':',@x) eq join(':',@leave)) {
X print "ok ",$test++,"\n";
X }
X else {
X print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
X }
X}
X
!STUFFY!FUNK!
echo Extracting t/io/tell.t
sed >t/io/tell.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: tell.t,v 4.0 91/03/20 01:51:14 lwall Locked $
X
Xprint "1..13\n";
X
X$TST = 'tst';
X
Xopen($TST, '../Makefile') || (die "Can't open ../Makefile");
X
Xif (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
X
X$firstline = <$TST>;
X$secondpos = tell;
X
X$x = 0;
Xwhile (<tst>) {
X if (eof) {$x++;}
X}
Xif ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
X
X$lastpos = tell;
X
Xunless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
X
Xif (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
X
Xif (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
X
Xif ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
X
Xif ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
X
Xif (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
X
Xif (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
X
Xif ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
X
Xif (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
X
Xif ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
X
Xunless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
!STUFFY!FUNK!
echo Extracting lib/pwd.pl
sed >lib/pwd.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# pwd.pl - keeps track of current working directory in PWD environment var
X;#
X;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $
X;#
X;# $Log: pwd.pl,v $
X;# Revision 4.0 91/03/20 01:26:03 lwall
X;# 4.0 baseline.
X;#
X;# Revision 3.0.1.2 91/01/11 18:09:24 lwall
X;# patch42: some .pl files were missing their trailing 1;
X;#
X;# Revision 3.0.1.1 90/08/09 04:01:24 lwall
X;# patch19: Initial revision
X;#
X;#
X;# Usage:
X;# require "pwd.pl";
X;# &initpwd;
X;# ...
X;# &chdir($newdir);
X
Xpackage pwd;
X
Xsub main'initpwd {
X if ($ENV{'PWD'}) {
X local($dd,$di) = stat('.');
X local($pd,$pi) = stat($ENV{'PWD'});
X return if $di == $pi && $dd == $pd;
X }
X chop($ENV{'PWD'} = `pwd`);
X}
X
Xsub main'chdir {
X local($newdir) = shift;
X if (chdir $newdir) {
X if ($newdir =~ m#^/#) {
X $ENV{'PWD'} = $newdir;
X }
X else {
X local(@curdir) = split(m#/#,$ENV{'PWD'});
X @curdir = '' unless @curdir;
X foreach $component (split(m#/#, $newdir)) {
X next if $component eq '.';
X pop(@curdir),next if $component eq '..';
X push(@curdir,$component);
X }
X $ENV{'PWD'} = join('/',@curdir) || '/';
X }
X }
X else {
X 0;
X }
X}
X
X1;
!STUFFY!FUNK!
echo Extracting os2/perldb.dif
sed >os2/perldb.dif <<'!STUFFY!FUNK!' -e 's/X//'
X*** lib/perldb.pl Tue Oct 23 23:14:20 1990
X--- os2/perldb.pl Tue Nov 06 21:13:42 1990
X***************
X*** 36,43 ****
X #
X #
X
X! open(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
X! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
X select(OUT);
X $| = 1; # for DB'OUT
X select(STDOUT);
X--- 36,43 ----
X #
X #
X
X! open(IN, "<con") || open(IN, "<&STDIN"); # so we don't dingle stdin
X! open(OUT,">con") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
X select(OUT);
X $| = 1; # for DB'OUT
X select(STDOUT);
X***************
X*** 517,530 ****
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X }
X
X! if (-f '.perldb') {
X! do './.perldb';
X }
X! elsif (-f "$ENV{'LOGDIR'}/.perldb") {
X! do "$ENV{'LOGDIR'}/.perldb";
X }
X! elsif (-f "$ENV{'HOME'}/.perldb") {
X! do "$ENV{'HOME'}/.perldb";
X }
X
X 1;
X--- 517,530 ----
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X }
X
X! if (-f 'perldb.ini') {
X! do './perldb.ini';
X }
X! elsif (-f "$ENV{'INIT'}/perldb.ini") {
X! do "$ENV{'INIT'}/perldb.ini";
X }
X! elsif (-f "$ENV{'HOME'}/perldb.ini") {
X! do "$ENV{'HOME'}/perldb.ini";
X }
X
X 1;
!STUFFY!FUNK!
echo Extracting t/base/lex.t
sed >t/base/lex.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: lex.t,v 4.0 91/03/20 01:49:08 lwall Locked $
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 :$foo:\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 4.0 91/03/20 01:13:44 lwall Locked $
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.t
sed >t/op/eval.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: eval.t,v 4.0 91/03/20 01:52:20 lwall Locked $
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 4.0 91/03/20 01:58:21 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: str.h,v $
X * Revision 4.0 91/03/20 01:58:21 lwall
X * 4.0 baseline.
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_mortal();
XSTR *str_make();
XSTR *str_nmake();
Xchar *str_gets();
!STUFFY!FUNK!
echo Extracting msdos/eg/drives.bat
sed >msdos/eg/drives.bat <<'!STUFFY!FUNK!' -e 's/X//'
X@REM=("
X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
X@end ") if 0 ;
X
X#
X# Test the ioctl function for MS-DOS. Provide a list of drives and their
X# characteristics.
X#
X# By Diomidis Spinellis.
X#
X
X@fdnum = ("STDIN", "STDOUT", "STDERR");
X$maxdrives = 15;
Xfor ($i = 3; $i < $maxdrives; $i++) {
X open("FD$i", "nul");
X @fdnum[$i - 1] = "FD$i";
X}
X@mediatype = (
X "320/360 k floppy drive",
X "1.2M floppy",
X "720K floppy",
X "8'' single density floppy",
X "8'' double density floppy",
X "fixed disk",
X "tape drive",
X "1.44M floppy",
X "other"
X);
Xprint "The system has the following drives:\n";
Xfor ($i = 1; $i < $maxdrives; $i++) {
X if ($ret = ioctl(@fdnum[$i], 8, 0)) {
X $type = ($ret == 0) ? "removable" : "fixed";
X $ret = ioctl(@fdnum[$i], 9, 0);
X $location = ($ret & 0x800) ? "local" : "remote";
X ioctl(@fdnum[$i], 0x860d, $param);
X @par = unpack("CCSSSC31S", $param);
X $lock = (@par[2] & 2) ? "supporting door lock" : "not supporting door lock";
X printf "%c:$type $location @mediatype[@par[1]] @par[3] cylinders @par[6]
X sectors/track $lock\n", ord('A') + $i - 1;
X }
X}
!STUFFY!FUNK!
echo Extracting t/op/each.t
sed >t/op/each.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $
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@keys = keys %h;
X@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@keys = ('blurfl', keys(%h), 'dyick');
Xif ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
!STUFFY!FUNK!
echo Extracting lib/getopt.pl
sed >lib/getopt.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header: getopt.pl,v 4.0 91/03/20 01:25:11 lwall Locked $
X
X;# Process single-character switches with switch clustering. Pass one argument
X;# which is a string containing all switches that take an argument. For each
X;# switch found, sets $opt_x (where x is the switch name) to the value of the
X;# argument, or 1 if no argument. Switches which take an argument don't care
X;# whether there is a space between the switch and the argument.
X
X;# Usage:
X;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
X
Xsub Getopt {
X local($argumentative) = @_;
X local($_,$first,$rest);
X local($[) = 0;
X
X while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
X ($first,$rest) = ($1,$2);
X if (index($argumentative,$first) >= $[) {
X if ($rest ne '') {
X shift(@ARGV);
X }
X else {
X shift(@ARGV);
X $rest = shift(@ARGV);
X }
X eval "\$opt_$first = \$rest;";
X }
X else {
X eval "\$opt_$first = 1;";
X if ($rest ne '') {
X $ARGV[0] = "-$rest";
X }
X else {
X shift(@ARGV);
X }
X }
X }
X}
X
X1;
!STUFFY!FUNK!
echo Extracting lib/look.pl
sed >lib/look.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
X
X;# Sets file position in FILEHANDLE to be first line greater than or equal
X;# (stringwise) to $key. Pass flags for dictionary order and case folding.
X
Xsub look {
X local(*FH,$key,$dict,$fold) = @_;
X local($max,$min,$mid,$_);
X local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
X $blksize,$blocks) = stat(FH);
X $blksize = 8192 unless $blksize;
X $key =~ s/[^\w\s]//g if $dict;
X $key =~ y/A-Z/a-z/ if $fold;
X $max = int($size / $blksize);
X while ($max - $min > 1) {
X $mid = int(($max + $min) / 2);
X seek(FH,$mid * $blksize,0);
X $_ = <FH> if $mid; # probably a partial line
X $_ = <FH>;
X chop;
X s/[^\w\s]//g if $dict;
X y/A-Z/a-z/ if $fold;
X if ($_ lt $key) {
X $min = $mid;
X }
X else {
X $max = $mid;
X }
X }
X $min *= $blksize;
X seek(FH,$min,0);
X <FH> if $min;
X while (<FH>) {
X chop;
X s/[^\w\s]//g if $dict;
X y/A-Z/a-z/ if $fold;
X last if $_ ge $key;
X $min = tell(FH);
X }
X seek(FH,$min,0);
X $min;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting t/op/time.t
sed >t/op/time.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $
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 x2p/handy.h
sed >x2p/handy.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:29:08 $
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 4.0.1.1 91/04/12 09:29:08 lwall
X * patch1: random cleanup in cpp namespace
X *
X * Revision 4.0 91/03/20 01:57:45 lwall
X * 4.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#ifdef TRUE
X#undef TRUE
X#endif
X#ifdef FALSE
X#undef FALSE
X#endif
X#define TRUE (1)
X#define FALSE (0)
X
X#define Ctl(ch) (ch & 037)
X
X#define strNE(s1,s2) (strcmp(s1,s2))
X#define strEQ(s1,s2) (!strcmp(s1,s2))
X#define strLT(s1,s2) (strcmp(s1,s2) < 0)
X#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
X#define strGT(s1,s2) (strcmp(s1,s2) > 0)
X#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
X#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
X#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
!STUFFY!FUNK!
echo Extracting t/op/do.t
sed >t/op/do.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $
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@x = ("ok 11\n", "ok 12\n");
X@y = ("ok 14\n", "ok 15\n");
Xdo blather(@x,"ok 13\n",@y);
!STUFFY!FUNK!
echo Extracting eg/sysvipc/ipcshm
sed >eg/sysvipc/ipcshm <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
X if 0;
X
Xrequire 'sys/ipc.ph';
Xrequire 'sys/shm.ph';
X
X$| = 1;
X
X$mode = shift;
Xdie "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/;
X$send = ($mode eq "s");
X
X$SIZE = 32;
X$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644);
Xdie "Can't get shared memory: $!\n" unless defined($id);
Xprint "shared memory id: $id\n";
X
Xif ($send) {
X while (<STDIN>) {
X chop;
X unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) {
X die "Can't write to shared memory: $!\n";
X }
X }
X}
Xelse {
X $SIG{'INT'} = $SIG{'QUIT'} = "leave";
X for (;;) {
X $_ = <STDIN>;
X unless (shmread($id, $_, 0, $SIZE)) {
X die "Can't read shared memory: $!\n";
X }
X $len = unpack("L", $_);
X $message = substr($_, length(pack("L",0)), $len);
X printf "[%d] %s\n", $len, $message;
X }
X}
X
X&leave;
X
Xsub leave {
X if (!$send) {
X $x = shmctl($id, &IPC_RMID, 0);
X if (!defined($x) || $x < 0) {
X die "Can't remove shared memory: $!\n";
X }
X }
X exit;
X}
!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 4.0 91/03/20 01:39:23 lwall Locked $
X *
X * $Log: regexp.h,v $
X * Revision 4.0 91/03/20 01:39:23 lwall
X * 4.0 baseline.
X *
X */
X
Xtypedef struct regexp {
X char **startp;
X char **endp;
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 *subend; /* end of subbase */
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 t/op/magic.t
sed >t/op/magic.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $
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
Xunlink 'ajslkdfpqjsjfk';
X$! = 0;
Xopen(foo,'ajslkdfpqjsjfk');
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@val1 = @ENV{keys(%ENV)}; # can we slice ENV?
X@val2 = values(%ENV);
X
Xprint join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
!STUFFY!FUNK!
echo Extracting msdos/eg/lf.bat
sed >msdos/eg/lf.bat <<'!STUFFY!FUNK!' -e 's/X//'
X@REM=("
X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
X@end ") if 0 ;
X
X# Convert all the files in the current directory from MS-DOS to unix
X# line ending conventions.
X#
X# By Diomidis Spinellis
X#
Xopen(FILES, 'find . -print |');
Xwhile ($file = <FILES>) {
X $file =^ s/[\n\r]//;
X if (-f $file) {
X if (-B $file) {
X print STDERR "Skipping binary file $file\n";
X next;
X }
X ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime,
X $blksize, $blocks) = stat($file);
X open(IFILE, "$file");
X open(OFILE, ">xl$$");
X binmode OFILE || die "binmode xl$$: $!\n";
X while (<IFILE>) {
X print OFILE;
X }
X close(OFILE) || die "close xl$$: $!\n";
X close(IFILE) || die "close $file: $!\n";
X unlink($file) || die "unlink $file: $!\n";
X rename("xl$$", $file) || die "rename(xl$$, $file): $!\n";
X chmod($mode, $file) || die "chmod($mode, $file: $!\n";
X utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n";
X }
X}
!STUFFY!FUNK!
echo Extracting t/cmd/for.t
sed >t/cmd/for.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: for.t,v 4.0 91/03/20 01:49:26 lwall Locked $
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@ary = (1,2,3,4,5);
Xforeach $foo (@ary) {
X $foo *= 2;
X}
Xif (join('',@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/base/term.t
sed >t/base/term.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: term.t,v 4.0 91/03/20 01:49:17 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 (<try> eq '') {
X print "ok 5\n";
X}
Xelse {
X print "not ok 5\n";
X die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
X}
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 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,$errs);
X local($[) = 0;
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(@ARGV);
X if($rest eq '') {
X $rest = shift(@ARGV);
X }
X eval "\$opt_$first = \$rest;";
X }
X else {
X eval "\$opt_$first = 1";
X if($rest eq '') {
X shift(@ARGV);
X }
X else {
X $ARGV[0] = "-$rest";
X }
X }
X }
X else {
X print STDERR "Unknown option: $first\n";
X ++$errs;
X if($rest ne '') {
X $ARGV[0] = "-$rest";
X }
X else {
X shift(@ARGV);
X }
X }
X }
X $errs == 0;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting t/io/argv.t
sed >t/io/argv.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: argv.t,v 4.0 91/03/20 01:50:46 lwall Locked $
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 :$x:\n";}
X
X@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 t/io/pipe.t
sed >t/io/pipe.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: pipe.t,v 4.0 91/03/20 01:51:02 lwall Locked $
X
X$| = 1;
Xprint "1..8\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(<PIPE>) {
X s/^not //;
X print;
X }
X}
Xelse {
X print STDOUT "not ok 3\n";
X exec 'echo', 'not ok 4';
X}
X
Xpipe(READER,WRITER) || die "Can't open pipe";
X
Xif ($pid = fork) {
X close WRITER;
X while(<READER>) {
X s/^not //;
X y/A-Z/a-z/;
X print;
X }
X}
Xelse {
X die "Couldn't fork" unless defined $pid;
X close READER;
X print WRITER "not ok 5\n";
X open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
X close WRITER;
X exec 'echo', 'not ok 6';
X}
X
X
Xpipe(READER,WRITER) || die "Can't open pipe";
Xclose READER;
X
X$SIG{'PIPE'} = 'broken_pipe';
X
Xsub broken_pipe {
X print "ok 7\n";
X}
X
Xprint WRITER "not ok 7\n";
Xclose WRITER;
X
Xprint "ok 8\n";
!STUFFY!FUNK!
echo Extracting msdos/eg/crlf.bat
sed >msdos/eg/crlf.bat <<'!STUFFY!FUNK!' -e 's/X//'
X@REM=("
X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
X@end ") if 0 ;
X
X# Convert all the files in the current directory from unix to MS-DOS
X# line ending conventions.
X#
X# By Diomidis Spinellis
X#
Xopen(FILES, 'find . -print |');
Xwhile ($file = <FILES>) {
X $file =^ s/[\n\r]//;
X if (-f $file) {
X if (-B $file) {
X print STDERR "Skipping binary file $file\n";
X next;
X }
X ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime,
X $blksize, $blocks) = stat($file);
X open(IFILE, "$file");
X open(OFILE, ">xl$$");
X while (<IFILE>) {
X print OFILE;
X }
X close(OFILE) || die "close xl$$: $!\n";
X close(IFILE) || die "close $file: $!\n";
X unlink($file) || die "unlink $file: $!\n";
X rename("xl$$", $file) || die "rename(xl$$, $file): $!\n";
X chmod($mode, $file) || die "chmod($mode, $file: $!\n";
X utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n";
X }
X}
!STUFFY!FUNK!
echo Extracting eg/changes
sed >eg/changes <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: changes,v 4.0 91/03/20 01:08:56 lwall Locked $
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 t/op/regexp.t
sed >t/op/regexp.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: regexp.t,v 4.0 91/03/20 01:54:22 lwall Locked $
X
Xopen(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
X || die "Can't open re_tests";
Xwhile (<TESTS>) { }
X$numtests = $.;
Xclose(TESTS);
X
Xprint "1..$numtests\n";
Xopen(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
X || 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 eg/myrup
sed >eg/myrup <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: myrup,v 4.0 91/03/20 01:11:16 lwall Locked $
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 eg/sysvipc/ipcmsg
sed >eg/sysvipc/ipcmsg <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
X if 0;
X
Xrequire 'sys/ipc.ph';
Xrequire 'sys/msg.ph';
X
X$| = 1;
X
X$mode = shift;
Xdie "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
X$send = ($mode eq "s");
X
X$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644);
Xdie "Can't get message queue: $!\n" unless defined($id);
Xprint "message queue id: $id\n";
X
Xif ($send) {
X while (<STDIN>) {
X chop;
X unless (msgsnd($id, pack("LA*", $., $_), 0)) {
X die "Can't send message: $!\n";
X }
X }
X}
Xelse {
X $SIG{'INT'} = $SIG{'QUIT'} = "leave";
X for (;;) {
X unless (msgrcv($id, $_, 512, 0, 0)) {
X die "Can't receive message: $!\n";
X }
X ($type, $message) = unpack("La*", $_);
X printf "[%d] %s\n", $type, $message;
X }
X}
X
X&leave;
X
Xsub leave {
X if (!$send) {
X $x = msgctl($id, &IPC_RMID, 0);
X if (!defined($x) || $x < 0) {
X die "Can't remove message queue: $!\n";
X }
X }
X exit;
X}
!STUFFY!FUNK!
echo Extracting eg/sysvipc/ipcsem
sed >eg/sysvipc/ipcsem <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
X if 0;
X
Xrequire 'sys/ipc.ph';
Xrequire 'sys/msg.ph';
X
X$| = 1;
X
X$mode = shift;
Xdie "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
X$signal = ($mode eq "s");
X
X$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644);
Xdie "Can't get semaphore: $!\n" unless defined($id);
Xprint "semaphore id: $id\n";
X
Xif ($signal) {
X while (<STDIN>) {
X print "Signalling\n";
X unless (semop($id, 0, pack("sss", 0, 1, 0))) {
X die "Can't signal semaphore: $!\n";
X }
X }
X}
Xelse {
X $SIG{'INT'} = $SIG{'QUIT'} = "leave";
X for (;;) {
X unless (semop($id, 0, pack("sss", 0, -1, 0))) {
X die "Can't wait for semaphore: $!\n";
X }
X print "Unblocked\n";
X }
X}
X
X&leave;
X
Xsub leave {
X if (!$signal) {
X $x = semctl($id, 0, &IPC_RMID, 0);
X if (!defined($x) || $x < 0) {
X die "Can't remove semaphore: $!\n";
X }
X }
X exit;
X}
!STUFFY!FUNK!
echo Extracting t/op/vec.t
sed >t/op/vec.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: vec.t,v 4.0 91/03/20 01:55:28 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 util.h
sed >util.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: util.h,v 4.0 91/03/20 01:56:48 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 4.0 91/03/20 01:56:48 lwall
X * 4.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();
X#ifndef HAS_MEMCPY
X#ifndef HAS_BCOPY
Xchar *bcopy();
X#endif
X#ifndef HAS_BZERO
Xchar *bzero();
X#endif
X#endif
Xunsigned long scanoct();
Xunsigned long scanhex();
!STUFFY!FUNK!
echo Extracting t/op/range.t
sed >t/op/range.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $
X
Xprint "1..8\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";
X
X$x = join('','a'..'z');
Xprint $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n";
X
X@x = 'A'..'ZZ';
Xprint @x == 27 * 26 ? "ok 8\n" : "not ok 8\n";
!STUFFY!FUNK!
echo Extracting form.h
sed >form.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: form.h,v 4.0 91/03/20 01:19: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: form.h,v $
X * Revision 4.0 91/03/20 01:19:37 lwall
X * 4.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#define F_DECIMAL 5
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 short f_decimals;
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#define FC_DP 16
X
X#define Nullfcmd Null(FCMD*)
X
XEXT char *chopset INIT(" \n-");
!STUFFY!FUNK!
echo Extracting x2p/util.h
sed >x2p/util.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: util.h,v 4.0 91/03/20 01:58:29 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 4.0 91/03/20 01:58:29 lwall
X * 4.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/dumpvar.pl
sed >lib/dumpvar.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xpackage dumpvar;
X
X# translate control chars to ^X - Randal Schwartz
Xsub unctrl {
X local($_) = @_;
X s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
X $_;
X}
Xsub main'dumpvar {
X ($package,@vars) = @_;
X local(*stab) = eval("*_$package");
X while (($key,$val) = each(%stab)) {
X {
X next if @vars && !grep($key eq $_,@vars);
X local(*entry) = $val;
X if (defined $entry) {
X print "\$$key = '",&unctrl($entry),"'\n";
X }
X if (defined @entry) {
X print "\@$key = (\n";
X foreach $num ($[ .. $#entry) {
X print " $num\t'",&unctrl($entry[$num]),"'\n";
X }
X print ")\n";
X }
X if ($key ne "_$package" && $key ne "_DB" && defined %entry) {
X print "\%$key = (\n";
X foreach $key (sort keys(%entry)) {
X print " $key\t'",&unctrl($entry{$key}),"'\n";
X }
X print ")\n";
X }
X }
X }
X}
X
X1;
!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/comp/multiline.t
sed >t/comp/multiline.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: multiline.t,v 4.0 91/03/20 01:50:15 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 (<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 t/op/local.t
sed >t/op/local.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: local.t,v 4.0 91/03/20 01:53:29 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 4.0 91/03/20 01:15:25 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 eg/travesty
sed >eg/travesty <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
Xwhile (<>) {
X next if /^\./;
X next if /^From / .. /^$/;
X next if /^Path: / .. /^$/;
X s/^\W+//;
X push(@ary,split(' '));
X while ($#ary > 1) {
X $a = $p;
X $p = $n;
X $w = shift(@ary);
X $n = $num{$w};
X if ($n eq '') {
X push(@word,$w);
X $n = pack('S',$#word);
X $num{$w} = $n;
X }
X $lookup{$a . $p} .= $n;
X }
X}
X
Xfor (;;) {
X $n = $lookup{$a . $p};
X ($foo,$n) = each(lookup) if $n eq '';
X $n = substr($n,int(rand(length($n))) & 0177776,2);
X $a = $p;
X $p = $n;
X ($w) = unpack('S',$n);
X $w = $word[$w];
X $col += length($w) + 1;
X if ($col >= 65) {
X $col = 0;
X print "\n";
X }
X else {
X print ' ';
X }
X print $w;
X if ($w =~ /\.$/) {
X if (rand() < .1) {
X print "\n";
X $col = 80;
X }
X }
X}
!STUFFY!FUNK!
echo Extracting msdos/Wishlist.dds
sed >msdos/Wishlist.dds <<'!STUFFY!FUNK!' -e 's/X//'
XPerl in general:
XAdd ftw or find?
XAdd a parsing mechanism (user specifies parse tree, perl parses).
XArbitrary precision arithmetic.
XFile calculus (e.g. file1 = file2 + file3, file1 =^ s/foo/bar/g etc.)
X
XMS-DOS version of Perl:
XAdd interface to treat dBase files as associative arrays.
XAdd int86x function.
XHandle the C preprocessor.
XProvide real pipes by switching the processes. (difficult)
XProvide a list of ioctl codes.
XCheck the ioctl errno handling.
XI can't find an easy way in Perl to pass a number as the first argument
X to ioctl. This is needed for some functions of ioctl. Either hack
X ioctl, or change perl to ioctl interface. Another solution would be
X a perl pseudo array containing the filehandles indexed by fd.
!STUFFY!FUNK!
echo Extracting h2pl/mksizes
sed >h2pl/mksizes <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/local/bin/perl
X
X($iam = $0) =~ s%.*/%%;
X$tmp = "$iam.$$";
Xopen (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n";
X
X$mask = q/printf ("$sizeof{'%s'} = %d;\n"/;
X
X# write C program
Xselect(CODE);
X
Xprint <<EO_C_PROGRAM;
X#include <sys/param.h>
X#include <sys/types.h>
X#include <sys/socket.h>
X#include <net/if_arp.h>
X#include <net/if.h>
X#include <net/route.h>
X#include <sys/ioctl.h>
X
Xmain() {
XEO_C_PROGRAM
X
Xwhile ( <> ) {
X chop;
X printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_;
X}
X
Xprint "\n}\n";
X
Xclose CODE;
X
X# compile C program
X
Xselect(STDOUT);
X
Xsystem "cc $tmp.c -o $tmp";
Xdie "couldn't compile $tmp.c" if $?;
Xsystem "./$tmp";
Xdie "couldn't run $tmp" if $?;
X
Xunlink "$tmp.c", $tmp;
!STUFFY!FUNK!
echo Extracting eg/scan/scan_passwd
sed >eg/scan/scan_passwd <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: scan_passwd,v 4.0 91/03/20 01:13:18 lwall Locked $
X
X# This scans passwd file for security holes.
X
Xopen(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n";
X# $dotriv = (`date` =~ /^Mon/);
X$dotriv = 1;
X
Xwhile (<Pass>) {
X ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
X if ($shell eq '') {
X print "Short: $_";
X }
X next if /^[+]/;
X if ($pass eq '') {
X if (index(":sync:lpq:+:", ":$login:") < 0) {
X print "No pass: $login\t$gcos\n";
X }
X }
X elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
X print "Trivial: $login\t$gcos\n";
X }
X if ($uid == 0) {
X if ($login !~ /^.?root$/ && $pass ne '*') {
X print "Extra root: $_";
X }
X }
X}
!STUFFY!FUNK!
echo Extracting h2pl/mkvars
sed >h2pl/mkvars <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
Xrequire 'sizeof.ph';
X
X$LIB = '/usr/local/lib/perl';
X
Xforeach $include (@ARGV) {
X printf STDERR "including %s\n", $include;
X do $include;
X warn "sourcing $include: $@\n" if ($@);
X if (!open (INCLUDE,"$LIB/$include")) {
X warn "can't open $LIB/$include: $!\n";
X next;
X }
X while (<INCLUDE>) {
X chop;
X if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) {
X $var = $1;
X $val = eval "&$var;";
X if ($@) {
X warn "$@: $_";
X print <<EOT
Xwarn "\$$var isn't correctly set" if defined \$_main{'$var'};
XEOT
X next;
X }
X ( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/;
X printf "\$%s = 0x%s;\n", $var, $nval;
X }
X }
X}
!STUFFY!FUNK!
echo Extracting hints/uts.sh
sed >hints/uts.sh <<'!STUFFY!FUNK!' -e 's/X//'
Xccflags="$ccflags -DCRIPPLED_CC -g"
Xd_lstat=$undef
!STUFFY!FUNK!
echo " "
echo "End of kit 35 (of 36)"
cat /dev/null >kit35isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
for combo in *:AA; do
if test -f "$combo"; then
realfile=`basename $combo :AA`
cat $realfile:[A-Z][A-Z] >$realfile
rm -rf $realfile:[A-Z][A-Z]
fi
done
rm -rf kit*isdone
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.