Path: utzoo!utgpu!news-server.csri.toronto.edu!rpi!usc!cs.utexas.edu!uunet!sparky!kent
From: lwall@netlabs.com (Larry Wall)
Newsgroups: comp.sources.misc
Subject: v18i052:  perl - The perl programming language, Part34/36
Message-ID: <1991Apr19.014951.5142@sparky.IMD.Sterling.COM>
Date: 19 Apr 91 01:49:51 GMT
Sender: kent@sparky.IMD.Sterling.COM (Kent Landfield)
Organization: NetLabs, Inc.
Lines: 1965
Approved: kent@sparky.imd.sterling.com
X-Checksum-Snefru: 9ec7af2a 039d76e1 a016c771 32513094

Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 52
Archive-name: perl/part34

[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 34 (of 36).  If kit 34 is complete, the line"
echo '"'"End of kit 34 (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/van h2pl h2pl/eg h2pl/eg/sys lib msdos os2 os2/eg t t/comp t/op usub x2p 2>/dev/null
echo Extracting os2/dir.h
sed >os2/dir.h <<'!STUFFY!FUNK!' -e 's/X//'
X/*
X * @(#) dir.h 1.4 87/11/06   Public Domain.
X *
X *  A public domain implementation of BSD directory routines for
X *  MS-DOS.  Written by Michael Rendell ({uunet,utai}michael@garfield),
X *  August 1987
X *
X *  Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype
X *  December 1989, February 1990
X *  Change of MAXPATHLEN for HPFS, October 1990
X */
X
X
X#define MAXNAMLEN  256
X#define MAXPATHLEN 256
X
X#define A_RONLY    0x01
X#define A_HIDDEN   0x02
X#define A_SYSTEM   0x04
X#define A_LABEL    0x08
X#define A_DIR      0x10
X#define A_ARCHIVE  0x20
X
X
Xstruct direct
X{
X  ino_t    d_ino;                   /* a bit of a farce */
X  int      d_reclen;                /* more farce */
X  int      d_namlen;                /* length of d_name */
X  char     d_name[MAXNAMLEN + 1];   /* null terminated */
X  /* nonstandard fields */
X  long     d_size;                  /* size in bytes */
X  unsigned d_mode;                  /* DOS or OS/2 file attributes */
X  unsigned d_time;
X  unsigned d_date;
X};
X
X/* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel).
X * The find_first and find_next calls deliver this data without any extra cost.
X * If this data is needed, these fields save a lot of extra calls to stat()
X * (each stat() again performs a find_first call !).
X */
X
Xstruct _dircontents
X{
X  char *_d_entry;
X  long _d_size;
X  unsigned _d_mode, _d_time, _d_date;
X  struct _dircontents *_d_next;
X};
X
Xtypedef struct _dirdesc
X{
X  int  dd_id;                   /* uniquely identify each open directory */
X  long dd_loc;                  /* where we are in directory entry is this */
X  struct _dircontents *dd_contents;   /* pointer to contents of dir */
X  struct _dircontents *dd_cp;         /* pointer to current position */
X}
XDIR;
X
X
Xextern int attributes;
X
Xextern DIR *opendir(char *);
Xextern struct direct *readdir(DIR *);
Xextern void seekdir(DIR *, long);
Xextern long telldir(DIR *);
Xextern void closedir(DIR *);
X#define rewinddir(dirp) seekdir(dirp, 0L)
X
Xextern int scandir(char *, struct direct ***,
X                   int (*)(struct direct *),
X                   int (*)(struct direct *, struct direct *));
X
Xextern int getfmode(char *);
Xextern int setfmode(char *, unsigned);
!STUFFY!FUNK!
echo Extracting os2/eg/os2.pl
sed >os2/eg/os2.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xextproc C:\binp\misc\perl.exe -S
X#!perl
X
X# os2.pl:  Demonstrates the OS/2 system calls and shows off some of the
X# features in common with the UNIX version.
X
Xdo "syscalls.pl" || die "Cannot load syscalls.pl ($!)";
X
X# OS/2 version number.
X
X	$version = "  "; syscall($OS2_GetVersion,$version); 
X	($minor, $major) = unpack("CC", $version);
X	print "You are using OS/2 version ", int($major/10), 
X			".", int($minor/10), "\n\n";
X 
X# Process ID.
X	print "This process ID is $$ and its parent's ID is ", 
X		getppid(), "\n\n";
X
X# Priority.
X
X	printf "Current priority is %x\n", getpriority(0,0);
X	print "Changing priority by +5\n";
X	print "Failed!\n" unless setpriority(0,0,+5);
X	printf "Priority is now %x\n\n", getpriority(0,0);
X
X# Beep.
X	print "Here is an A440.\n\n";
X	syscall($OS2_Beep,440,50);
X
X# Pipes.  Unlike MS-DOS, OS/2 supports true asynchronous pipes.
X	open(ROT13, '|perl -pe y/a-zA-Z/n-za-mN-ZA-M/') || die;
X	select(ROT13); $|=1; select(STDOUT);
X	print "Type two lines of stuff, and I'll ROT13 it while you wait.\n".
X	      "If you type fast, you might be able to type both of your\n".
X	      "lines before I get a chance to translate the first line.\n";
X	$_ = <STDIN>; print ROT13 $_;
X	$_ = <STDIN>; print ROT13 $_;
X	close(ROT13);
X	print "Thanks.\n\n";
X
X# Inspecting the disks.
X	print "Let's look at the disks you have installed...\n\n";
X
X	$x = "\0\0";
X	syscall($OS2_Config, $x, 2);
X	print "You have ", unpack("S", $x), " floppy disks,\n";
X
X	$x = "  ";
X	syscall($OS2_PhysicalDisk, 1, $x, 2, 0, 0);
X	($numdisks) = unpack("S", $x);
X
X	print "and $numdisks partitionable disks.\n\n";
X	for ($i = 1; $i <= $numdisks; $i++) {
X		$disk = $i . ":";
X		$handle = "  ";
X		syscall($OS2_PhysicalDisk, 2, $handle, 2, $disk, 3);
X		($numhandle) = unpack("S", $handle);
X		$zero = pack("C", 0);
X		$parmblock = " " x 16;
X		syscall($OS2_IOCtl, $parmblock, $zero, 0x63, 9, $numhandle);
X		($x, $cylinders, $heads, $sect) = unpack("SSSS", $parmblock);
X		print "Hard drive #$i:\n";
X		print "   cylinders: $cylinders\n";
X		print "       heads: $heads\n";
X		print "    sect/trk: $sect\n";
X		syscall($OS2_PhysicalDisk, 3, 0, 0, $handle, 2);
X	}
X
X# I won't bother with the other stuff.  You get the idea.
X
!STUFFY!FUNK!
echo Extracting t/op/write.t
sed >t/op/write.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $
X
Xprint "1..3\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"; }
X
Xformat OUT2 =
Xthe quick brown @<<
X$fox
Xjumped
X@*
X$multiline
X^<<<<<<<<< ~~
X$foo
Xnow @<<the@>>>> for all@|||||men to come @<<<<
X'i' . 's', "time\n", $good, 'to'
X.
X
Xopen(OUT2, '>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(OUT2);
Xclose OUT2;
X
X$right =
X"the quick brown fox
Xjumped
Xforescore
Xand
Xseven years
Xwhen in
Xthe course
Xof human
Xevents it
Xbecomes
Xnecessary
Xnow is the time for all good men to come to\n";
X
Xif (`cat Op.write.tmp` eq $right)
X    { print "ok 2\n"; unlink 'Op.write.tmp'; }
Xelse
X    { print "not ok 2\n"; }
X
Xeval <<'EOFORMAT';
Xformat OUT2 =
Xthe brown quick @<<
X$fox
Xjumped
X@*
X$multiline
X^<<<<<<<<< ~~
X$foo
Xnow @<<the@>>>> for all@|||||men to come @<<<<
X'i' . 's', "time\n", $good, 'to'
X.
XEOFORMAT
X
Xopen(OUT2, '>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(OUT2);
Xclose OUT2;
X
X$right =
X"the brown quick fox
Xjumped
Xforescore
Xand
Xseven years
Xwhen in
Xthe course
Xof human
Xevents it
Xbecomes
Xnecessary
Xnow is the time for all good men to come to\n";
X
Xif (`cat Op.write.tmp` eq $right)
X    { print "ok 3\n"; unlink 'Op.write.tmp'; }
Xelse
X    { print "not ok 3\n"; }
X
!STUFFY!FUNK!
echo Extracting lib/complete.pl
sed >lib/complete.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;#
X;#	@(#)complete.pl	1.0 (sun!waynet) 11/11/88
X;#
X;# Author: Wayne Thompson
X;#
X;# Description:
X;#     This routine provides word completion.
X;#     (TAB) attempts word completion.
X;#     (^D)  prints completion list.
X;#	(These may be changed by setting $Complete'complete, etc.)
X;#
X;# Diagnostics:
X;#     Bell when word completion fails.
X;#
X;# Dependencies:
X;#     The tty driver is put into raw mode.
X;#
X;# Bugs:
X;#
X;# Usage:
X;#     $input = do Complete('prompt_string', @completion_list);
X;#
X
XCONFIG: {
X    package Complete;
X
X    $complete =	"\004";
X    $kill =	"\025";
X    $erase1 =	"\177";
X    $erase2 =	"\010";
X}
X
Xsub Complete {
X    package Complete;
X
X    local ($prompt) = shift (@_);
X    local ($c, $cmp, $l, $r, $ret, $return, $test);
X    @_cmp_lst = sort @_;
X    local($[) = 0;
X    system 'stty raw -echo';
X    loop: {
X	print $prompt, $return;
X	while (($c = getc(stdin)) ne "\r") {
X	    if ($c eq "\t") {			# (TAB) attempt completion
X		@_match = ();
X		foreach $cmp (@_cmp_lst) {
X		    push (@_match, $cmp) if $cmp =~ /^$return/;
X		}
X    	    	$test = $_match[0];
X    	    	$l = length ($test);
X		unless ($#_match == 0) {
X    	    	    shift (@_match);
X    	    	    foreach $cmp (@_match) {
X    	    	    	until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) {
X    	    	    	    $l--;
X    	    	    	}
X    	    	    }
X    	    	    print "\007";
X    	    	}
X    	    	print $test = substr ($test, $r, $l - $r);
X    	    	$r = length ($return .= $test);
X	    }
X	    elsif ($c eq $complete) {		# (^D) completion list
X		print "\r\n";
X		foreach $cmp (@_cmp_lst) {
X		    print "$cmp\r\n" if $cmp =~ /^$return/;
X		}
X		redo loop;
X	    }
X    	    elsif ($c eq $kill && $r) {	# (^U) kill
X    	    	$return = '';
X    	    	$r = 0;
X    	    	print "\r\n";
X    	    	redo loop;
X    	    }
X	    	    	    	    	    	# (DEL) || (BS) erase
X	    elsif ($c eq $erase1 || $c eq $erase2) {
X		if($r) {
X		    print "\b \b";
X		    chop ($return);
X		    $r--;
X		}
X	    }
X	    elsif ($c =~ /\S/) {    	    	# printable char
X		$return .= $c;
X		$r++;
X		print $c;
X	    }
X	}
X    }
X    system 'stty -raw echo';
X    print "\n";
X    $return;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting eg/scan/scanner
sed >eg/scan/scanner <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: scanner,v 4.0 91/03/20 01:14:11 lwall Locked $
X
X# This runs all the scan_* routines on all the machines in /etc/ghosts.
X# We run this every morning at about 6 am:
X
X#	!/bin/sh
X#	cd /usr/adm/private
X#	decrypt scanner | perl >scan.out 2>&1
X#	mail admin <scan.out
X
X# Note that the scan_* files should be encrypted with the key "-inquire", and
X# scanner should be encrypted somehow so that people can't find that key.
X# I leave it up to you to figure out how to unencrypt it before executing.
X
X$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
X
X$| = 1;		# command buffering on stdout
X
Xprint "Subject: bizarre happenings\n\n";
X
X(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
X
Xif ($#ARGV >= 0) {
X    @scanlist = @ARGV;
X} else {
X    @scanlist = split(/[ \t\n]+/,`echo scan_*`);
X}
X
Xscan: while ($scan = shift(@scanlist)) {
X    print "\n********** $scan **********\n";
X    $showhost++;
X
X    $systype = 'all';
X
X    open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
X
X    $one_of_these = ":$systype:";
X    if ($systype =~ s/\+/[+]/g) {
X	$one_of_these =~ s/\+/:/g;
X    }
X
X    line: while (<ghosts>) {
X	s/[ \t]*\n//;
X	if (!$_ || /^#/) {
X	    next line;
X	}
X	if (/^([a-zA-Z_0-9]+)=(.+)/) {
X	    $name = $1; $repl = $2;
X	    $repl =~ s/\+/:/g;
X	    $one_of_these =~ s/:$name:/:$repl:/;
X	    next line;
X	}
X	@gh = split;
X	$host = $gh[0];
X	if ($showhost) { $showhost = "$host:\t"; }
X	class: while ($class = pop(gh)) {
X	    if (index($one_of_these,":$class:") >=0) {
X		$iter = 0;
X		`exec crypt -inquire <$scan >.x 2>/dev/null`;
X		unless (open(scan,'.x')) {
X		    print "Can't run $scan: $!\n";
X		    next scan;
X		}
X		$cmd = <scan>;
X		unless ($cmd =~ s/#!(.*)\n/$1/) {
X		    $cmd = '/usr/bin/perl';
X		}
X		close(scan);
X		if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
X		    sleep(5);
X		    unlink '.x';
X		    while (<PIPE>) {
X			last if $iter++ > 1000;		# must be looping
X			next if /^[0-9.]+u [0-9.]+s/;
X			print $showhost,$_;
X		    }
X		    close(PIPE);
X		} else {
X		    print "(Can't execute rsh: $!)\n";
X		}
X		last class;
X	    }
X	}
X    }
X}
!STUFFY!FUNK!
echo Extracting eg/g/gcp.man
sed >eg/g/gcp.man <<'!STUFFY!FUNK!' -e 's/X//'
X.\" $Header: gcp.man,v 4.0 91/03/20 01:10:13 lwall Locked $
X.TH GCP 1C "13 May 1988"
X.SH NAME
Xgcp \- global file copy
X.SH SYNOPSIS
X.B gcp
Xfile1 file2
X.br
X.B gcp
X[
X.B \-r
X] file ... directory
X.SH DESCRIPTION
X.I gcp
Xworks just like rcp(1C) except that you may specify a set of hosts to copy files
Xfrom or to.
XThe host sets are defined in the file /etc/ghosts.
X(An individual host name can be used as a set containing one member.)
XYou can give a command like
X
X	gcp /etc/motd sun:
X
Xto copy your /etc/motd file to /etc/motd on all the Suns.
XIf, on the other hand, you say
X
X	gcp /a/foo /b/bar sun:/tmp
X
Xthen your files will be copied to /tmp on all the Suns.
XThe general rule is that if you don't specify the destination directory,
Xfiles go to the same directory they are in currently.
X.P
XYou may specify the union of two or more sets by using + as follows:
X
X	gcp /a/foo /b/bar 750+mc:
X
Xwhich will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
X/b/bar to /b/bar on all 750's and Masscomps.
X.P
XCommonly used sets should be defined in /etc/ghosts.
XFor example, you could add a line that says
X
X	pep=manny+moe+jack
X
XAnother way to do that would be to add the word "pep" after each of the host
Xentries:
X
X	manny	sun3 pep
X.br
X	moe		sun3 pep
X.br
X	jack		sun3 pep
X
XHosts and sets of host can also be excluded:
X
X	foo=sun-sun2
X
XAny host so excluded will never be included, even if a subsequent set on the
Xline includes it:
X
X	foo=abc+def
X.br
X	bar=xyz-abc+foo
X
Xcomes out to xyz+def.
X
XYou can define private host sets by creating .ghosts in your current directory
Xwith entries just like /etc/ghosts.
XAlso, if there is a file .grem, it defines "rem" to be the remaining hosts
Xfrom the last gsh or gcp that didn't succeed everywhere.
X.PP
XInterrupting with a SIGINT will cause the rcp to the current host to be skipped
Xand execution resumed with the next host.
XTo stop completely, send a SIGQUIT.
X.SH SEE ALSO
Xrcp(1C)
X.SH BUGS
XAll the bugs of rcp, since it calls rcp.
!STUFFY!FUNK!
echo Extracting t/TEST
sed >t/TEST <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: TEST,v 4.0 91/03/20 01:40:22 lwall Locked $
X
X# This is written in a peculiar style, since we're trying to avoid
X# most of the constructs we'll be testing for.
X
X$| = 1;
X
Xif ($ARGV[0] eq '-v') {
X    $verbose = 1;
X    shift;
X}
X
Xchdir 't' if -f 't/TEST';
X
Xif ($ARGV[0] eq '') {
X    @ARGV = split(/[ \n]/,
X      `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
X}
X
Xopen(CONFIG,"../config.sh");
Xwhile (<CONFIG>) {
X    if (/sharpbang='(.*)'/) {
X	$sharpbang = ($1 eq '#!');
X	last;
X    }
X}
X$bad = 0;
Xwhile ($test = shift) {
X    if ($test =~ /^$/) {
X	next;
X    }
X    $te = $test;
X    chop($te);
X    print "$te" . '.' x (15 - length($te));
X    if ($sharpbang) {
X	open(results,"./$test|") || (print "can't run.\n");
X    } else {
X	open(script,"$test") || die "Can't run $test.\n";
X	$_ = <script>;
X	close(script);
X	if (/#!..perl(.*)/) {
X	    $switch = $1;
X	} else {
X	    $switch = '';
X	}
X	open(results,"./perl$switch $test|") || (print "can't run.\n");
X    }
X    $ok = 0;
X    $next = 0;
X    while (<results>) {
X	if ($verbose) {
X	    print $_;
X	}
X	unless (/^#/) {
X	    if (/^1\.\.([0-9]+)/) {
X		$max = $1;
X		$next = 1;
X		$ok = 1;
X	    } else {
X		$next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
X		if (/^ok (.*)/ && $1 == $next) {
X		    $next = $next + 1;
X		} else {
X		    $ok = 0;
X		}
X	    }
X	}
X    }
X    $next = $next - 1;
X    if ($ok && $next == $max) {
X	print "ok\n";
X    } else {
X	$next += 1;
X	print "FAILED on test $next\n";
X	$bad = $bad + 1;
X	$_ = $test;
X	if (/^base/) {
X	    die "Failed a basic test--cannot continue.\n";
X	}
X    }
X}
X
Xif ($bad == 0) {
X    if ($ok) {
X	print "All tests successful.\n";
X    } else {
X	die "FAILED--no tests were run for some reason.\n";
X    }
X} else {
X    if ($bad == 1) {
X	die "Failed 1 test.\n";
X    } else {
X	die "Failed $bad tests.\n";
X    }
X}
X($user,$sys,$cuser,$csys) = times;
Xprint sprintf("u=%g  s=%g  cu=%g  cs=%g\n",$user,$sys,$cuser,$csys);
!STUFFY!FUNK!
echo Extracting eg/rename
sed >eg/rename <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X'di';
X'ig00';
X#
X# $Header: rename,v 4.0 91/03/20 01:11:53 lwall Locked $
X#
X# $Log:	rename,v $
X# Revision 4.0  91/03/20  01:11:53  lwall
X# 4.0 baseline.
X# 
X# Revision 3.0.1.2  90/08/09  03:17:57  lwall
X# patch19: added man page for relink and rename
X# 
X
X($op = shift) || die "Usage: rename perlexpr [filenames]\n";
Xif (!@ARGV) {
X    @ARGV = <STDIN>;
X    chop(@ARGV);
X}
Xfor (@ARGV) {
X    $was = $_;
X    eval $op;
X    die $@ if $@;
X    rename($was,$_) unless $was eq $_;
X}
X##############################################################################
X
X	# These next few lines are legal in both Perl and nroff.
X
X.00;			# finish .ig
X 
X'di			\" finish diversion--previous line must be blank
X.nr nl 0-1		\" fake up transition to first page again
X.nr % 0			\" start at page 1
X';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
X.TH RENAME 1 "July 30, 1990"
X.AT 3
X.SH NAME
Xrename \- renames multiple files
X.SH SYNOPSIS
X.B rename perlexpr [files]
X.SH DESCRIPTION
X.I Rename
Xrenames the filenames supplied according to the rule specified as the
Xfirst argument.
XThe argument is a Perl expression which is expected to modify the $_
Xstring in Perl for at least some of the filenames specified.
XIf a given filename is not modified by the expression, it will not be
Xrenamed.
XIf no filenames are given on the command line, filenames will be read
Xvia standard input.
X.PP
XFor example, to rename all files matching *.bak to strip the extension,
Xyou might say
X.nf
X
X	rename 's/\e.bak$//' *.bak
X
X.fi
XTo translate uppercase names to lower, you'd use
X.nf
X
X	rename 'y/A-Z/a-z/' *
X
X.fi
X.SH ENVIRONMENT
XNo environment variables are used.
X.SH FILES
X.SH AUTHOR
XLarry Wall
X.SH "SEE ALSO"
Xmv(1)
X.br
Xperl(1)
X.SH DIAGNOSTICS
XIf you give an invalid Perl expression you'll get a syntax error.
X.SH BUGS
X.I Rename
Xdoes not check for the existence of target filenames, so use with care.
X.ex
!STUFFY!FUNK!
echo Extracting msdos/usage.c
sed >msdos/usage.c <<'!STUFFY!FUNK!' -e 's/X//'
X/*	usage.c
X *
X * Show usage message.
X */
X
X#include <stdio.h>
X#include <string.h>
X
X
Xusage(char *myname)
X{
Xchar	* p;
Xchar 	* name_p;
X
Xname_p = myname;
Xif ( p = strrchr(myname,'/') )
X	name_p = p+1;	/* point after final '/' */
X#ifdef MSDOS
Xif ( p = strrchr(name_p,'\\') )
X	name_p = p+1;	/* point after final '\\' */
Xif ( p = strrchr(name_p,':') )
X	name_p = p+1;	/* point after final ':' */
X  printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]"
X#else
X  printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]"
X#endif
X         "\n            [-e \"command\"] [-x[directory]] [filename] [arguments]\n", name_p);
X
X  printf("\n  -a  autosplit mode with -n or -p"
X         "\n  -c  syntaxcheck only"
X         "\n  -d  run scripts under debugger"
X         "\n  -n  assume 'while (<>) { ...script... }' loop arround your script"
X         "\n  -p  assume loop like -n but print line also like sed"
X#ifndef MSDOS
X         "\n  -P  run script through C preprocessor befor compilation"
X#endif
X         "\n  -s  enable some switch parsing for switches after script name"
X         "\n  -S  look for the script using PATH environment variable");
X#ifndef MSDOS
X  printf("\n  -u  dump core after compiling the script"
X         "\n  -U  allow unsafe operations");
X#endif
X  printf("\n  -v  print version number and patchlevel of perl"
X         "\n  -w  turn warnings on for compilation of your script\n"
X         "\n  -Dnumber        set debugging flags"
X         "\n  -i[extension]   edit <> files in place (make backup if extension supplied)"
X         "\n  -Idirectory     specify include directory in conjunction with -P"
X         "\n  -e command      one line of script, multiple -e options are allowed"
X         "\n                  [filename] can be ommitted, when -e is used"
X         "\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
X}
!STUFFY!FUNK!
echo Extracting t/op/split.t
sed >t/op/split.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $
X
Xprint "1..12\n";
X
X$FS = ':';
X
X$_ = 'a:b:c';
X
X($a,$b,$c) = split($FS,$_);
X
Xif (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";}
X
X@ary = split(/:b:/);
Xif (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";}
X
X$_ = "abc\n";
X@xyz = (@ary = split(//));
Xif (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";}
X
X$_ = "a:b:c::::";
X@ary = split(/:/);
Xif (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";}
X
X$_ = join(':',split(' ',"    a b\tc \t d "));
Xif ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";}
X
X$_ = join(':',split(/ */,"foo  bar bie\tdoll"));
Xif ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l")
X	{print "ok 6\n";} else {print "not ok 6\n";}
X
X$_ = join(':', 'foo', split(/ /,'a b  c'), 'bar');
Xif ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
X
X# Can we say how many fields to split to?
X$_ = join(':', split(' ','1 2 3 4 5 6', 3));
Xprint $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n";
X
X# Can we do it as a variable?
X$x = 4;
X$_ = join(':', split(' ','1 2 3 4 5 6', $x));
Xprint $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n";
X
X# Does the 999 suppress null field chopping?
X$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
Xprint $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n";
X
X# Does assignment to a list imply split to one more field than that?
X$foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`;
Xprint $foo =~ /DEBUGGING/ || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n";
X
X# Can we say how many fields to split to when assigning to a list?
X($a,$b) = split(' ','1 2 3 4 5 6', 2);
X$_ = join(':',$a,$b);
Xprint $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n";
X
!STUFFY!FUNK!
echo Extracting h2pl/eg/sys/errno.pl
sed >h2pl/eg/sys/errno.pl <<'!STUFFY!FUNK!' -e 's/X//'
X$EPERM = 0x1;
X$ENOENT = 0x2;
X$ESRCH = 0x3;
X$EINTR = 0x4;
X$EIO = 0x5;
X$ENXIO = 0x6;
X$E2BIG = 0x7;
X$ENOEXEC = 0x8;
X$EBADF = 0x9;
X$ECHILD = 0xA;
X$EAGAIN = 0xB;
X$ENOMEM = 0xC;
X$EACCES = 0xD;
X$EFAULT = 0xE;
X$ENOTBLK = 0xF;
X$EBUSY = 0x10;
X$EEXIST = 0x11;
X$EXDEV = 0x12;
X$ENODEV = 0x13;
X$ENOTDIR = 0x14;
X$EISDIR = 0x15;
X$EINVAL = 0x16;
X$ENFILE = 0x17;
X$EMFILE = 0x18;
X$ENOTTY = 0x19;
X$ETXTBSY = 0x1A;
X$EFBIG = 0x1B;
X$ENOSPC = 0x1C;
X$ESPIPE = 0x1D;
X$EROFS = 0x1E;
X$EMLINK = 0x1F;
X$EPIPE = 0x20;
X$EDOM = 0x21;
X$ERANGE = 0x22;
X$EWOULDBLOCK = 0x23;
X$EINPROGRESS = 0x24;
X$EALREADY = 0x25;
X$ENOTSOCK = 0x26;
X$EDESTADDRREQ = 0x27;
X$EMSGSIZE = 0x28;
X$EPROTOTYPE = 0x29;
X$ENOPROTOOPT = 0x2A;
X$EPROTONOSUPPORT = 0x2B;
X$ESOCKTNOSUPPORT = 0x2C;
X$EOPNOTSUPP = 0x2D;
X$EPFNOSUPPORT = 0x2E;
X$EAFNOSUPPORT = 0x2F;
X$EADDRINUSE = 0x30;
X$EADDRNOTAVAIL = 0x31;
X$ENETDOWN = 0x32;
X$ENETUNREACH = 0x33;
X$ENETRESET = 0x34;
X$ECONNABORTED = 0x35;
X$ECONNRESET = 0x36;
X$ENOBUFS = 0x37;
X$EISCONN = 0x38;
X$ENOTCONN = 0x39;
X$ESHUTDOWN = 0x3A;
X$ETOOMANYREFS = 0x3B;
X$ETIMEDOUT = 0x3C;
X$ECONNREFUSED = 0x3D;
X$ELOOP = 0x3E;
X$ENAMETOOLONG = 0x3F;
X$EHOSTDOWN = 0x40;
X$EHOSTUNREACH = 0x41;
X$ENOTEMPTY = 0x42;
X$EPROCLIM = 0x43;
X$EUSERS = 0x44;
X$EDQUOT = 0x45;
X$ESTALE = 0x46;
X$EREMOTE = 0x47;
X$EDEADLK = 0x48;
X$ENOLCK = 0x49;
X$MTH_UNDEF_SQRT = 0x12C;
X$MTH_OVF_EXP = 0x12D;
X$MTH_UNDEF_LOG = 0x12E;
X$MTH_NEG_BASE = 0x12F;
X$MTH_ZERO_BASE = 0x130;
X$MTH_OVF_POW = 0x131;
X$MTH_LRG_SIN = 0x132;
X$MTH_LRG_COS = 0x133;
X$MTH_LRG_TAN = 0x134;
X$MTH_LRG_COT = 0x135;
X$MTH_OVF_TAN = 0x136;
X$MTH_OVF_COT = 0x137;
X$MTH_UNDEF_ASIN = 0x138;
X$MTH_UNDEF_ACOS = 0x139;
X$MTH_UNDEF_ATAN2 = 0x13A;
X$MTH_OVF_SINH = 0x13B;
X$MTH_OVF_COSH = 0x13C;
X$MTH_UNDEF_ZLOG = 0x13D;
X$MTH_UNDEF_ZDIV = 0x13E;
!STUFFY!FUNK!
echo Extracting t/op/substr.t
sed >t/op/substr.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $
X
Xprint "1..22\n";
X
X$a = 'abcdefxyz';
X
Xprint (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
Xprint (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
Xprint (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
Xprint (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
Xprint (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n");
Xprint (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
X
X$[ = 1;
X
Xprint (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
Xprint (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
Xprint (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
Xprint (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
Xprint (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n");
Xprint (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
X
X$[ = 0;
X
Xsubstr($a,3,3) = 'XYZ';
Xprint $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
Xsubstr($a,0,2) = '';
Xprint $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
Xy/a/a/;
Xsubstr($a,0,0) = 'ab';
Xprint $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
Xsubstr($a,0,0) = '12345678';
Xprint $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
Xsubstr($a,-3,3) = 'def';
Xprint $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
Xsubstr($a,-3,3) = '<';
Xprint $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
Xsubstr($a,-1,1) = '12345678';
Xprint $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
X
X$a = 'abcdefxyz';
X
Xprint (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");
Xprint (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");
Xprint (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n");
!STUFFY!FUNK!
echo Extracting t/op/index.t
sed >t/op/index.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $
X
Xprint "1..20\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");
X
Xprint index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n";
Xprint index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n";
Xprint index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n";
Xprint index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n";
Xprint index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n";
Xprint index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n";
Xprint index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n";
X
Xprint rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n";
Xprint rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n";
Xprint rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n";
Xprint rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n";
Xprint rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n";
Xprint rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n";
Xprint rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n";
!STUFFY!FUNK!
echo Extracting hash.h
sed >hash.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.h,v 4.0 91/03/20 01:22:38 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:	hash.h,v $
X * Revision 4.0  91/03/20  01:22:38  lwall
X * 4.0 baseline.
X * 
X */
X
X#define FILLPCT 80		/* don't make greater than 99 */
X#define DBM_CACHE_MAX 63	/* cache 64 entries for dbm file */
X				/* (resident array acts as a write-thru cache)*/
X
X#define COEFFSIZE (16 * 8)	/* size of coeff array */
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    int		hent_klen;
X};
X
Xstruct htbl {
X    HENT	**tbl_array;
X    int		tbl_max;	/* subscript of last element of tbl_array */
X    int		tbl_dosplit;	/* how full to get before splitting */
X    int		tbl_fill;	/* how full tbl_array currently is */
X    int		tbl_riter;	/* current root of iterator */
X    HENT	*tbl_eiter;	/* current entry of iterator */
X    SPAT 	*tbl_spatroot;	/* list of spats for this package */
X    char	*tbl_name;	/* name, if a symbol table */
X#ifdef SOME_DBM
X#ifdef HAS_GDBM
X    GDBM_FILE	tbl_dbm;
X#else
X#ifdef HAS_NDBM
X    DBM		*tbl_dbm;
X#else
X    int		tbl_dbm;
X#endif
X#endif
X#endif
X    unsigned char tbl_coeffsize;	/* is 0 for symbol tables */
X};
X
XSTR *hfetch();
Xbool hstore();
XSTR *hdelete();
XHASH *hnew();
Xvoid hclear();
Xvoid hentfree();
Xint hiterinit();
XHENT *hiternext();
Xchar *hiterkey();
XSTR *hiterval();
Xbool hdbmopen();
Xvoid hdbmclose();
Xbool hdbmstore();
!STUFFY!FUNK!
echo Extracting t/op/repeat.t
sed >t/op/repeat.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $
X
Xprint "1..19\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
X@x = (1,2,3);
X
Xprint join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
Xprint join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
Xprint join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
Xprint join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
Xprint join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
Xprint join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
Xprint join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
Xprint join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
!STUFFY!FUNK!
echo Extracting msdos/dir.h
sed >msdos/dir.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: dir.h,v 4.0 91/03/20 01:34:20 lwall Locked $
X *
X *    (C) Copyright 1987, 1990 Diomidis Spinellis.
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:	dir.h,v $
X * Revision 4.0  91/03/20  01:34:20  lwall
X * 4.0 baseline.
X * 
X * Revision 3.0.1.1  90/03/27  16:07:08  lwall
X * patch16: MSDOS support
X * 
X * Revision 1.1  90/03/18  20:32:29  dds
X * Initial revision
X *
X *
X */
X
X/*
X * defines the type returned by the directory(3) functions
X */
X
X#ifndef __DIR_INCLUDED
X#define __DIR_INCLUDED
X
X/*Directory entry size */
X#ifdef DIRSIZ
X#undef DIRSIZ
X#endif
X#define DIRSIZ(rp)	(sizeof(struct direct))
X
X/*
X * Structure of a directory entry
X */
Xstruct direct	{
X	ino_t	d_ino;			/* inode number (not used by MS-DOS) */
X	int	d_namlen;		/* Name length */
X	char	d_name[13];		/* file name */
X};
X
Xstruct _dir_struc {			/* Structure used by dir operations */
X	char *start;			/* Starting position */
X	char *curr;			/* Current position */
X	struct direct dirstr;		/* Directory structure to return */
X};
X
Xtypedef struct _dir_struc DIR;		/* Type returned by dir operations */
X
XDIR *cdecl opendir(char *filename);
Xstruct direct *readdir(DIR *dirp);
Xlong telldir(DIR *dirp);
Xvoid seekdir(DIR *dirp,long loc);
Xvoid rewinddir(DIR *dirp);
Xvoid closedir(DIR *dirp);
X
X#endif /* __DIR_INCLUDED */
!STUFFY!FUNK!
echo Extracting spat.h
sed >spat.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: spat.h,v 4.0 91/03/20 01:39:36 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:	spat.h,v $
X * Revision 4.0  91/03/20  01:39:36  lwall
X * 4.0 baseline.
X * 
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 t/op/undef.t
sed >t/op/undef.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $
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@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@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@ary = (1);
Xprint defined @ary ? "ok 17\n" : "not ok 17\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 eg/van/unvanish
sed >eg/van/unvanish <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: unvanish,v 4.0 91/03/20 01:15:38 lwall Locked $
X
Xsub it {
X    if ($olddir ne '.') {
X	chop($pwd = `pwd`) if $pwd eq '';
X	(chdir $olddir) || die "Directory $olddir is not accesible";
X    }
X    unless ($olddir eq '.deleted') {
X	if (-d '.deleted') {
X	    chdir '.deleted' || die "Directory .deleted is not accesible";
X	}
X	else {
X	    chop($pwd = `pwd`) if $pwd eq '';
X	    die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
X	}
X    }
X    print `mv $startfiles$filelist..$force`;
X    if ($olddir ne '.') {
X	(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
X    }
X}
X
Xif ($#ARGV < 0) {
X    open(lastcmd,'.deleted/.lastcmd') || 
X	open(lastcmd,'.lastcmd') || 
X	    die "No previous vanish in this dir";
X    $ARGV = <lastcmd>;
X    close(lastcmd);
X    @ARGV = split(/[\n ]+/,$ARGV);
X}
X
Xwhile ($ARGV[0] =~ /^-/) {
X    $_ = shift;
X    /^-f/ && ($force = ' >/dev/null 2>&1');
X    /^-i/ && ($interactive = 1);
X    if (/^-+$/) {
X	$startfiles = '- ';
X	last;
X    }
X}
X
Xwhile ($file = shift) {
X    if ($file =~ s|^(.*)/||) {
X	$dir = $1;
X    }
X    else {
X	$dir = '.';
X    }
X
X    if ($dir ne $olddir) {
X	do it() if $olddir;
X	$olddir = $dir;
X    }
X
X    if ($interactive) {
X	print "unvanish: restore $dir/$file? ";
X	next unless <stdin> =~ /^y/i;
X    }
X
X    $filelist .= $file; $filelist .= ' ';
X
X}
X
Xdo it() if $olddir;
!STUFFY!FUNK!
echo Extracting cflags.SH
sed >cflags.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 2>/dev/null
X    . ./config.sh
X    ;;
Xesac
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
X
Xalso=': '
Xcase $# in
X1) also='echo 1>&2 "	  CFLAGS = "'
Xesac
X
Xcase $# in
X0) set *.c; echo "The current C flags are:" ;;
X*) set `echo "$* " | sed 's/\.o /.c /g'`
Xesac
Xfor file do
X
X    case "$#" in
X    1) ;;
X    *) echo $n "    $file	$c" ;;
X    esac
X
X    case "$file" in
X    array.c) ;;
X    cmd.c) ;;
X    cons.c) ;;
X    consarg.c) ;;
X    doarg.c) ;;
X    doio.c) ;;
X    dolist.c) ;;
X    dump.c) ;;
X    eval.c) ;;
X    form.c) ;;
X    hash.c) ;;
X    malloc.c) ;;
X    perl.c) ;;
X    perly.c) ;;
X    regcomp.c) ;;
X    regexec.c) ;;
X    stab.c) ;;
X    str.c) ;;
X    toke.c) ;;
X    usersub.c) ;;
X    util.c) ;;
X    tarray.c) ;;
X    tcmd.c) ;;
X    tcons.c) ;;
X    tconsarg.c) ;;
X    tdoarg.c) ;;
X    tdoio.c) ;;
X    tdolist.c) ;;
X    tdump.c) ;;
X    teval.c) ;;
X    tform.c) ;;
X    thash.c) ;;
X    tmalloc.c) ;;
X    tperl.c) ;;
X    tperly.c) ;;
X    tregcomp.c) ;;
X    tregexec.c) ;;
X    tstab.c) ;;
X    tstr.c) ;;
X    ttoke.c) ;;
X    tusersub.c) ;;
X    tutil.c) ;;
X    *) ;;
X    esac
X
X    echo "$ccflags $optimize $large $split"
X    eval "$also $ccflags $optimize $large $split"
Xdone
!STUFFY!FUNK!
echo Extracting eg/van/vanish
sed >eg/van/vanish <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# $Header: vanish,v 4.0 91/03/20 01:16:05 lwall Locked $
X
Xsub it {
X    if ($olddir ne '.') {
X	chop($pwd = `pwd`) if $pwd eq '';
X	(chdir $olddir) || die "Directory $olddir is not accesible";
X    }
X    if (!-d .deleted) {
X	print `mkdir .deleted; chmod 775 .deleted`;
X	die "You can't remove files from $olddir" if $?;
X    }
X    $filelist =~ s/ $//;
X    $filelist =~ s/#/\\#/g;
X    if ($filelist !~ /^[ \t]*$/) {
X	open(lastcmd,'>.deleted/.lastcmd');
X	print lastcmd $filelist,"\n";
X	close(lastcmd);
X	print `/bin/mv $startfiles$filelist .deleted$force`;
X    }
X    if ($olddir ne '.') {
X	(chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
X    }
X}
X
Xwhile ($ARGV[0] =~ /^-/) {
X    $_ = shift;
X    /^-f/ && ($force = ' >/dev/null 2>&1');
X    /^-i/ && ($interactive = 1);
X    if (/^-+$/) {
X	$startfiles = '- ';
X	last;
X    }
X}
X
Xchop($pwd = `pwd`);
X
Xwhile ($file = shift) {
X    if ($file =~ s|^(.*)/||) {
X	$dir = $1;
X    }
X    else {
X	$dir = '.';
X    }
X
X    if ($interactive) {
X	print "vanish: remove $dir/$file? ";
X	next unless <stdin> =~ /^y/i;
X    }
X
X    if ($file eq '.deleted') {
X	print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
X	next;
X    }
X
X    if ($dir ne $olddir) {
X	do it() if $olddir;
X	$olddir = $dir;
X    }
X
X    $filelist .= $file; $filelist .= ' ';
X}
X
Xdo it() if $olddir;
!STUFFY!FUNK!
echo 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 4.0 91/03/20 01:12:28 lwall Locked $
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 usub/man2mus
sed >usub/man2mus <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
Xwhile (<>) {
X    if (/^\.SH SYNOPSIS/) {
X	$spec = '';
X	for ($_ = <>; $_ && !/^\.SH/; $_ = <>) {
X	    s/^\.[IRB][IRB]\s*//;
X	    s/^\.[IRB]\s+//;
X	    next if /^\./;
X	    s/\\f\w//g;
X	    s/\\&//g;
X	    s/^\s+//;
X	    next if /^$/;
X	    next if /^#/;
X	    $spec .= $_;
X	}
X	$_ = $spec;
X	0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g;
X	s/\(\*([^,;]*)\)\(\)/(*)()$1/g;
X	s/(\w+)\[\]/*$1/g;
X
X	s/\n/ /g;
X	s/\s+/ /g;
X	s/(\w+) \(([^*])/$1($2/g;
X	s/^ //;
X	s/ ?; ?/\n/g;
X	s/\) /)\n/g;
X	s/ \* / \*/g;
X	s/\* / \*/g;
X
X	$* = 1;
X	0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g;
X	$* = 0;
X	s/\|/,/g;
X
X	@cases = ();
X	for (reverse split(/\n/,$_)) {
X	    if (/\)$/) {
X		($type,$name,$args) = split(/(\w+)\(/);
X		$type =~ s/ $//;
X		if ($type =~ /^(\w+) =/) {
X		    $type = $type{$1} if $type{$1};
X		}
X		$type = 'int' if $type eq '';
X		@args = grep(/./, split(/[,)]/,$args));
X		$case = "CASE $type $name\n";
X		foreach $arg (@args) {
X		    $type = $type{$arg} || "int";
X		    $type =~ s/ //g;
X		    $type .= "\t" if length($type) < 8;
X		    if ($type =~ /\*/) {
X			$case .= "IO	$type	$arg\n";
X		    }
X		    else {
X			$case .= "I	$type	$arg\n";
X		    }
X		}
X		$case .= "END\n\n";
X		unshift(@cases, $case);
X	    }
X	    else {
X		$type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/;
X	    }
X	}
X	print @cases;
X    }
X}
!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 2>/dev/null
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 4.0 91/03/20 01:27:13 lwall Locked $
X# 
X# $Log:	makedir.SH,v $
X# Revision 4.0  91/03/20  01:27:13  lwall
X# 4.0 baseline.
X# 
X# 
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/scan/scan_last
sed >eg/scan/scan_last <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_last,v 4.0 91/03/20 01:12:45 lwall Locked $
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 4.0 91/03/20 01:57:53 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:	hash.h,v $
X * Revision 4.0  91/03/20  01:57:53  lwall
X * 4.0 baseline.
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.t
sed >t/comp/term.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
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@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 os2/glob.c
sed >os2/glob.c <<'!STUFFY!FUNK!' -e 's/X//'
X/*
X * Globbing for OS/2.  Relies on the expansion done by the library
X * startup code. (dds)
X */
X
X#include <stdio.h>
X#include <string.h>
X
Xmain(int argc, char *argv[])
X{
X  register i;
X
X  for (i = 1; i < argc; i++)
X  {
X    fputs(IsFileSystemFAT(argv[i]) ? strlwr(argv[i]) : argv[i], stdout);
X    putchar(0);
X  }
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 34 (of 36)"
cat /dev/null >kit34isdone
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.