Usenet 1994 October

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

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

Wrap

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

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 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.