Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/unix/volume20/perl3.0/part24

Internet Message Format | 1989-11-01 | 44.6 KB

Subject:  v20i107:  Perl, a language with features of C/sed/awk/shell/etc, Part24/24
Newsgroups: comp.sources.unix
Sender: sources
Approved: [e-mail]

Submitted-by: Larry Wall <[e-mail]>
Posting-number: Volume 20, Issue 107
Archive-name: perl3.0/part24

#! /bin/sh

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

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