home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 January
/
usenetsourcesnewsgroupsinfomagicjanuary1994.iso
/
sources
/
misc
/
volume18
/
perl
/
part32
< prev
next >
Wrap
Internet Message Format
|
1991-04-20
|
51KB
From: lwall@netlabs.com (Larry Wall)
Newsgroups: comp.sources.misc
Subject: v18i050: perl - The perl programming language, Part32/36
Message-ID: <1991Apr19.014918.4993@sparky.IMD.Sterling.COM>
Date: 19 Apr 91 01:49:18 GMT
Approved: kent@sparky.imd.sterling.com
X-Checksum-Snefru: 44efcec8 d0e9bce7 d23c186a 78357a51
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 50
Archive-name: perl/part32
[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 32 (of 36). If kit 32 is complete, the line"
echo '"'"End of kit 32 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir lib msdos t t/cmd t/op usub 2>/dev/null
echo Extracting msdos/directory.c
sed >msdos/directory.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $
X *
X * (C) Copyright 1987, 1988, 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: directory.c,v $
X * Revision 4.0 91/03/20 01:34:24 lwall
X * 4.0 baseline.
X *
X * Revision 3.0.1.1 90/03/27 16:07:37 lwall
X * patch16: MSDOS support
X *
X * Revision 1.3 90/03/16 22:39:40 dds
X * Fixed malloc problem.
X *
X * Revision 1.2 88/07/23 00:08:39 dds
X * Added inode non-zero filling.
X *
X * Revision 1.1 88/07/23 00:03:50 dds
X * Initial revision
X *
X */
X
X/*
X * UNIX compatible directory access functions
X */
X
X#include <sys/types.h>
X#include <sys/dir.h>
X#include <stddef.h>
X#include <stdlib.h>
X#include <string.h>
X#include <dos.h>
X#include <ctype.h>
X
X/*
X * File names are converted to lowercase if the
X * CONVERT_TO_LOWER_CASE variable is defined.
X */
X#define CONVERT_TO_LOWER_CASE
X
X#define PATHLEN 65
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $";
X#endif
X
XDIR *
Xopendir(char *filename)
X{
X DIR *p;
X char *oldresult, *result;
X union REGS srv;
X struct SREGS segregs;
X register reslen = 0;
X char scannamespc[PATHLEN];
X char *scanname = scannamespc; /* To take address we need a pointer */
X
X /*
X * Structure used by the MS-DOS directory system calls.
X */
X struct dir_buff {
X char reserved[21]; /* Reserved for MS-DOS */
X unsigned char attribute; /* Attribute */
X unsigned int time; /* Time */
X unsigned int date; /* Date */
X long size; /* Size of file */
X char fn[13]; /* Filename */
X } buffspc, *buff = &buffspc;
X
X
X if (!(p = (DIR *) malloc(sizeof(DIR))))
X return NULL;
X
X /* Initialize result to use realloc on it */
X if (!(result = malloc(1))) {
X free(p);
X return NULL;
X }
X
X /* Create the search pattern */
X strcpy(scanname, filename);
X if (strchr("/\\", *(scanname + strlen(scanname) - 1)) == NULL)
X strcat(scanname, "/*.*");
X else
X strcat(scanname, "*.*");
X
X segread(&segregs);
X#if ( defined(M_I86LM) || defined(M_I86CM) || defined(M_I86HM) )
X segregs.ds = FP_SEG(buff);
X srv.x.dx = FP_OFF(buff);
X#else
X srv.x.dx = (unsigned int) buff;
X#endif
X srv.h.ah = 0x1a; /* Set DTA to DS:DX */
X intdosx(&srv, &srv, &segregs);
X
X#if ( defined(M_I86LM) || defined(M_I86CM) || defined(M_I86HM) )
X segregs.ds = FP_SEG(scanname);
X srv.x.dx = FP_OFF(scanname);
X#else
X srv.x.dx = (unsigned int) scanname;
X#endif
X srv.x.cx = 0xff; /* Search mode */
X
X for (srv.h.ah = 0x4e; !intdosx(&srv, &srv, &segregs); srv.h.ah = 0x4f) {
X if ((result = (char *) realloc(result, reslen + strlen(buff->fn) + 1)) ==
X NULL) {
X free(p);
X free(oldresult);
X return NULL;
X }
X oldresult = result;
X#ifdef CONVERT_TO_LOWER_CASE
X strcpy(result + reslen, strlwr(buff->fn));
X#else
X strcpy(result + reslen, buff->fn);
X#endif
X reslen += strlen(buff->fn) + 1;
X }
X
X if (!(result = realloc(result, reslen + 1))) {
X free(p);
X free(oldresult);
X return NULL;
X } else {
X p->start = result;
X p->curr = result;
X *(result + reslen) = '\0';
X return p;
X }
X}
X
X
Xstruct direct *
Xreaddir(DIR *dirp)
X{
X char *p;
X register len;
X static dummy;
X
X p = dirp->curr;
X len = strlen(p);
X if (*p) {
X dirp->curr += len + 1;
X strcpy(dirp->dirstr.d_name, p);
X dirp->dirstr.d_namlen = len;
X /* To fool programs */
X dirp->dirstr.d_ino = ++dummy;
X return &(dirp->dirstr);
X } else
X return NULL;
X}
X
Xlong
Xtelldir(DIR *dirp)
X{
X return (long) dirp->curr; /* ouch! pointer to long cast */
X}
X
Xvoid
Xseekdir(DIR *dirp, long loc)
X{
X dirp->curr = (char *) loc; /* ouch! long to pointer cast */
X}
X
Xvoid
Xrewinddir(DIR *dirp)
X{
X dirp->curr = dirp->start;
X}
X
Xvoid
Xclosedir(DIR *dirp)
X{
X free(dirp->start);
X free(dirp);
X}
!STUFFY!FUNK!
echo Extracting ioctl.pl
sed >ioctl.pl <<'!STUFFY!FUNK!' -e 's/X//'
X$TIOCGSIZE = 0x40087468;
X$TIOCSSIZE = 0x80087467;
X$IOCPARM_MASK = 0x1fff;
X$IOCPARM_MAX = 0x200;
X$IOC_VOID = 0x20000000;
X$IOC_OUT = 0x40000000;
X$IOC_IN = 0x80000000;
X$IOC_INOUT = 0xC0000000;
X$IOC_DIRMASK = 0xe0000000;
X$TIOCGETD = 0x40047400;
X$TIOCSETD = 0x80047401;
X$TIOCHPCL = 0x20007402;
X$TIOCMODG = 0x40047403;
X$TIOCMODS = 0x80047404;
X$TIOCM_LE = 0001;
X$TIOCM_DTR = 0002;
X$TIOCM_RTS = 0004;
X$TIOCM_ST = 0010;
X$TIOCM_SR = 0020;
X$TIOCM_CTS = 0040;
X$TIOCM_CAR = 0100;
X$TIOCM_CD = 0x40;
X$TIOCM_RNG = 0200;
X$TIOCM_RI = 0x80;
X$TIOCM_DSR = 0400;
X$TIOCGETP = 0x40067408;
X$TIOCSETP = 0x80067409;
X$TIOCSETN = 0x8006740A;
X$TIOCEXCL = 0x2000740D;
X$TIOCNXCL = 0x2000740E;
X$TIOCFLUSH = 0x80047410;
X$TIOCSETC = 0x80067411;
X$TIOCGETC = 0x40067412;
X$TANDEM = 0x00000001;
X$CBREAK = 0x00000002;
X$LCASE = 0x00000004;
X$ECHO = 0x00000008;
X$CRMOD = 0x00000010;
X$RAW = 0x00000020;
X$ODDP = 0x00000040;
X$EVENP = 0x00000080;
X$ANYP = 0x000000c0;
X$NLDELAY = 0x00000300;
X$NL0 = 0x00000000;
X$NL1 = 0x00000100;
X$NL2 = 0x00000200;
X$NL3 = 0x00000300;
X$TBDELAY = 0x00000c00;
X$TAB0 = 0x00000000;
X$TAB1 = 0x00000400;
X$TAB2 = 0x00000800;
X$XTABS = 0x00000c00;
X$CRDELAY = 0x00003000;
X$CR0 = 0x00000000;
X$CR1 = 0x00001000;
X$CR2 = 0x00002000;
X$CR3 = 0x00003000;
X$VTDELAY = 0x00004000;
X$FF0 = 0x00000000;
X$FF1 = 0x00004000;
X$BSDELAY = 0x00008000;
X$BS0 = 0x00000000;
X$BS1 = 0x00008000;
X$ALLDELAY = 0xFF00;
X$CRTBS = 0x00010000;
X$PRTERA = 0x00020000;
X$CRTERA = 0x00040000;
X$TILDE = 0x00080000;
X$MDMBUF = 0x00100000;
X$LITOUT = 0x00200000;
X$TOSTOP = 0x00400000;
X$FLUSHO = 0x00800000;
X$NOHANG = 0x01000000;
X$L001000 = 0x02000000;
X$CRTKIL = 0x04000000;
X$PASS8 = 0x08000000;
X$CTLECH = 0x10000000;
X$PENDIN = 0x20000000;
X$DECCTQ = 0x40000000;
X$NOFLSH = 0x80000000;
X$TIOCLBIS = 0x8004747F;
X$TIOCLBIC = 0x8004747E;
X$TIOCLSET = 0x8004747D;
X$TIOCLGET = 0x4004747C;
X$LCRTBS = 0x1;
X$LPRTERA = 0x2;
X$LCRTERA = 0x4;
X$LTILDE = 0x8;
X$LMDMBUF = 0x10;
X$LLITOUT = 0x20;
X$LTOSTOP = 0x40;
X$LFLUSHO = 0x80;
X$LNOHANG = 0x100;
X$LCRTKIL = 0x400;
X$LPASS8 = 0x800;
X$LCTLECH = 0x1000;
X$LPENDIN = 0x2000;
X$LDECCTQ = 0x4000;
X$LNOFLSH = 0xFFFF8000;
X$TIOCSBRK = 0x2000747B;
X$TIOCCBRK = 0x2000747A;
X$TIOCSDTR = 0x20007479;
X$TIOCCDTR = 0x20007478;
X$TIOCGPGRP = 0x40047477;
X$TIOCSPGRP = 0x80047476;
X$TIOCSLTC = 0x80067475;
X$TIOCGLTC = 0x40067474;
X$TIOCOUTQ = 0x40047473;
X$TIOCSTI = 0x80017472;
X$TIOCNOTTY = 0x20007471;
X$TIOCPKT = 0x80047470;
X$TIOCPKT_DATA = 0x00;
X$TIOCPKT_FLUSHREAD = 0x01;
X$TIOCPKT_FLUSHWRITE = 0x02;
X$TIOCPKT_STOP = 0x04;
X$TIOCPKT_START = 0x08;
X$TIOCPKT_NOSTOP = 0x10;
X$TIOCPKT_DOSTOP = 0x20;
X$TIOCSTOP = 0x2000746F;
X$TIOCSTART = 0x2000746E;
X$TIOCMSET = 0x8004746D;
X$TIOCMBIS = 0x8004746C;
X$TIOCMBIC = 0x8004746B;
X$TIOCMGET = 0x4004746A;
X$TIOCREMOTE = 0x80047469;
X$TIOCGWINSZ = 0x40087468;
X$TIOCSWINSZ = 0x80087467;
X$TIOCUCNTL = 0x80047466;
X$TIOCSSOFTC = 0x80047465;
X$TIOCGSOFTC = 0x40047464;
X$TIOCSCARR = 0x80047463;
X$TIOCWCARR = 0x20007462;
X$OTTYDISC = 0;
X$NETLDISC = 1;
X$NTTYDISC = 2;
X$TABLDISC = 3;
X$SLIPDISC = 4;
X$FIOCLEX = 0x20006601;
X$FIONCLEX = 0x20006602;
X$FIONREAD = 0x4004667F;
X$FIONBIO = 0x8004667E;
X$FIOASYNC = 0x8004667D;
X$FIOSETOWN = 0x8004667C;
X$FIOGETOWN = 0x4004667B;
X$SIOCSHIWAT = 0x80047300;
X$SIOCGHIWAT = 0x40047301;
X$SIOCSLOWAT = 0x80047302;
X$SIOCGLOWAT = 0x40047303;
X$SIOCATMARK = 0x40047307;
X$SIOCSPGRP = 0x80047308;
X$SIOCGPGRP = 0x40047309;
X$SIOCADDRT = 0x8030720A;
X$SIOCDELRT = 0x8030720B;
X$SIOCSIFADDR = 0x8020690C;
X$SIOCGIFADDR = 0xC020690D;
X$SIOCSIFDSTADDR = 0x8020690E;
X$SIOCGIFDSTADDR = 0xC020690F;
X$SIOCSIFFLAGS = 0x80206910;
X$SIOCGIFFLAGS = 0xC0206911;
X$SIOCGIFBRDADDR = 0xC0206912;
X$SIOCSIFBRDADDR = 0x80206913;
X$SIOCGIFCONF = 0xC0086914;
X$SIOCGIFNETMASK = 0xC0206915;
X$SIOCSIFNETMASK = 0x80206916;
X$SIOCGIFMETRIC = 0xC0206917;
X$SIOCSIFMETRIC = 0x80206918;
X$SIOCSARP = 0x8024691E;
X$SIOCGARP = 0xC024691F;
X$SIOCDARP = 0x80246920;
!STUFFY!FUNK!
echo Extracting lib/validate.pl
sed >lib/validate.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header: validate.pl,v 4.0 91/03/20 01:26:56 lwall Locked $
X
X;# The validate routine takes a single multiline string consisting of
X;# lines containing a filename plus a file test to try on it. (The
X;# file test may also be a 'cd', causing subsequent relative filenames
X;# to be interpreted relative to that directory.) After the file test
X;# you may put '|| die' to make it a fatal error if the file test fails.
X;# The default is '|| warn'. The file test may optionally have a ! prepended
X;# to test for the opposite condition. If you do a cd and then list some
X;# relative filenames, you may want to indent them slightly for readability.
X;# If you supply your own "die" or "warn" message, you can use $file to
X;# interpolate the filename.
X
X;# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
X;# Only the first failed test of the bunch will produce a warning.
X
X;# The routine returns the number of warnings issued.
X
X;# Usage:
X;# require "validate.pl";
X;# $warnings += do validate('
X;# /vmunix -e || die
X;# /boot -e || die
X;# /bin cd
X;# csh -ex
X;# csh !-ug
X;# sh -ex
X;# sh !-ug
X;# /usr -d || warn "What happened to $file?\n"
X;# ');
X
Xsub validate {
X local($file,$test,$warnings,$oldwarnings);
X foreach $check (split(/\n/,$_[0])) {
X next if $check =~ /^#/;
X next if $check =~ /^$/;
X ($file,$test) = split(' ',$check,2);
X if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
X $testlist = $2;
X @testlist = split(//,$testlist);
X }
X else {
X @testlist = ('Z');
X }
X $oldwarnings = $warnings;
X foreach $one (@testlist) {
X $this = $test;
X $this =~ s/(-\w\b)/$1 \$file/g;
X $this =~ s/-Z/-$one/;
X $this .= ' || warn' unless $this =~ /\|\|/;
X $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
X $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
X eval $this;
X last if $warnings > $oldwarnings;
X }
X }
X $warnings;
X}
X
Xsub valmess {
X local($disposition,$this) = @_;
X $file = $cwd . '/' . $file unless $file =~ m|^/|;
X if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
X $neg = $1;
X $tmp = $2;
X $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
X $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
X $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
X $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
X $tmp eq 'R' && ($mess = "$file is not readable by you.");
X $tmp eq 'W' && ($mess = "$file is not writable by you.");
X $tmp eq 'X' && ($mess = "$file is not executable by you.");
X $tmp eq 'O' && ($mess = "$file is not owned by you.");
X $tmp eq 'e' && ($mess = "$file does not exist.");
X $tmp eq 'z' && ($mess = "$file does not have zero size.");
X $tmp eq 's' && ($mess = "$file does not have non-zero size.");
X $tmp eq 'f' && ($mess = "$file is not a plain file.");
X $tmp eq 'd' && ($mess = "$file is not a directory.");
X $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
X $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
X $tmp eq 'S' && ($mess = "$file is not a socket.");
X $tmp eq 'b' && ($mess = "$file is not a block special file.");
X $tmp eq 'c' && ($mess = "$file is not a character special file.");
X $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
X $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
X $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
X $tmp eq 'T' && ($mess = "$file is not a text file.");
X $tmp eq 'B' && ($mess = "$file is not a binary file.");
X if ($neg eq '!') {
X $mess =~ s/ is not / should not be / ||
X $mess =~ s/ does not / should not / ||
X $mess =~ s/ not / /;
X }
X print stderr $mess,"\n";
X }
X else {
X $this =~ s/\$file/'$file'/g;
X print stderr "Can't do $this.\n";
X }
X if ($disposition eq 'die') { exit 1; }
X ++$warnings;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting stab.h
sed >stab.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: stab.h,v 4.0 91/03/20 01:39:49 lwall Locked $
X *
X * Copyright (c) 1989, Larry Wall
X *
X * You may distribute under the terms of the GNU General Public License
X * as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log: stab.h,v $
X * Revision 4.0 91/03/20 01:39:49 lwall
X * 4.0 baseline.
X *
X */
X
Xstruct stabptrs {
X char stbp_magic[4];
X STR *stbp_val; /* scalar value */
X struct stio *stbp_io; /* filehandle value */
X FCMD *stbp_form; /* format value */
X ARRAY *stbp_array; /* array value */
X HASH *stbp_hash; /* associative array value */
X HASH *stbp_stash; /* symbol table for this stab */
X SUBR *stbp_sub; /* subroutine value */
X int stbp_lastexpr; /* used by nothing_in_common() */
X line_t stbp_line; /* line first declared at (for -w) */
X char stbp_flags;
X};
X
X#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
X#define MICROPORT
X#endif
X
X#define stab_magic(stab) (((STBP*)(stab->str_ptr))->stbp_magic)
X#define stab_val(stab) (((STBP*)(stab->str_ptr))->stbp_val)
X#define stab_io(stab) (((STBP*)(stab->str_ptr))->stbp_io)
X#define stab_form(stab) (((STBP*)(stab->str_ptr))->stbp_form)
X#define stab_xarray(stab) (((STBP*)(stab->str_ptr))->stbp_array)
X#ifdef MICROPORT /* Microport 2.4 hack */
XARRAY *stab_array();
X#else
X#define stab_array(stab) (((STBP*)(stab->str_ptr))->stbp_array ? \
X ((STBP*)(stab->str_ptr))->stbp_array : \
X ((STBP*)(aadd(stab)->str_ptr))->stbp_array)
X#endif
X#define stab_xhash(stab) (((STBP*)(stab->str_ptr))->stbp_hash)
X#ifdef MICROPORT /* Microport 2.4 hack */
XHASH *stab_hash();
X#else
X#define stab_hash(stab) (((STBP*)(stab->str_ptr))->stbp_hash ? \
X ((STBP*)(stab->str_ptr))->stbp_hash : \
X ((STBP*)(hadd(stab)->str_ptr))->stbp_hash)
X#endif /* Microport 2.4 hack */
X#define stab_stash(stab) (((STBP*)(stab->str_ptr))->stbp_stash)
X#define stab_sub(stab) (((STBP*)(stab->str_ptr))->stbp_sub)
X#define stab_lastexpr(stab) (((STBP*)(stab->str_ptr))->stbp_lastexpr)
X#define stab_line(stab) (((STBP*)(stab->str_ptr))->stbp_line)
X#define stab_flags(stab) (((STBP*)(stab->str_ptr))->stbp_flags)
X#define stab_name(stab) (stab->str_magic->str_ptr)
X
X#define SF_VMAGIC 1 /* call routine to dereference STR val */
X#define SF_MULTI 2 /* seen more than once */
X
Xstruct stio {
X FILE *ifp; /* ifp and ofp are normally the same */
X FILE *ofp; /* but sockets need separate streams */
X#ifdef HAS_READDIR
X DIR *dirp; /* for opendir, readdir, etc */
X#endif
X long lines; /* $. */
X long page; /* $% */
X long page_len; /* $= */
X long lines_left; /* $- */
X char *top_name; /* $^ */
X STAB *top_stab; /* $^ */
X char *fmt_name; /* $~ */
X STAB *fmt_stab; /* $~ */
X short subprocess; /* -| or |- */
X char type;
X char flags;
X};
X
X#define IOF_ARGV 1 /* this fp iterates over ARGV */
X#define IOF_START 2 /* check for null ARGV and substitute '-' */
X#define IOF_FLUSH 4 /* this fp wants a flush after write op */
X
Xstruct sub {
X CMD *cmd;
X int (*usersub)();
X int userindex;
X STAB *filestab;
X long depth; /* >= 2 indicates recursive call */
X ARRAY *tosave;
X};
X
X#define Nullstab Null(STAB*)
X
X#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
X#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
X#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
X
XEXT STAB *tmpstab;
X
XEXT STAB *stab_index[128];
X
XEXT unsigned short statusvalue;
X
XEXT int delaymagic INIT(0);
X#define DM_DELAY 1
X#define DM_REUID 2
X#define DM_REGID 4
X
XSTAB *aadd();
XSTAB *hadd();
XSTAB *fstab();
!STUFFY!FUNK!
echo Extracting usersub.c
sed >usersub.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: usersub.c,v 4.0 91/03/20 01:55:56 lwall Locked $
X *
X * This file contains stubs for routines that the user may define to
X * set up glue routines for C libraries or to decrypt encrypted scripts
X * for execution.
X *
X * $Log: usersub.c,v $
X * Revision 4.0 91/03/20 01:55:56 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
Xuserinit()
X{
X return 0;
X}
X
X/*
X * The following is supplied by John MacDonald as a means of decrypting
X * and executing (presumably proprietary) scripts that have been encrypted
X * by a (presumably secret) method. The idea is that you supply your own
X * routine in place of cryptfilter (which is purposefully a very weak
X * encryption). If an encrypted script is detected, a process is forked
X * off to run the cryptfilter routine as input to perl.
X */
X
X#ifdef CRYPTSCRIPT
X
X#include <signal.h>
X#ifdef I_VFORK
X#include <vfork.h>
X#endif
X
X#define CRYPT_MAGIC_1 0xfb
X#define CRYPT_MAGIC_2 0xf1
X
Xcryptfilter( fil )
XFILE * fil;
X{
X int ch;
X
X while( (ch = getc( fil )) != EOF ) {
X putchar( (ch ^ 0x80) );
X }
X}
X
X#ifndef MSDOS
Xstatic FILE *lastpipefile;
Xstatic int pipepid;
X
X#ifdef VOIDSIG
X# define VOID void
X#else
X# define VOID int
X#endif
X
XFILE *
Xmypfiopen(fil,func) /* open a pipe to function call for input */
XFILE *fil;
XVOID (*func)();
X{
X int p[2];
X STR *str;
X
X if (pipe(p) < 0) {
X fclose( fil );
X fatal("Can't get pipe for decrypt");
X }
X
X /* make sure that the child doesn't get anything extra */
X fflush(stdout);
X fflush(stderr);
X
X while ((pipepid = fork()) < 0) {
X if (errno != EAGAIN) {
X close(p[0]);
X close(p[1]);
X fclose( fil );
X fatal("Can't fork for decrypt");
X }
X sleep(5);
X }
X if (pipepid == 0) {
X close(p[0]);
X if (p[1] != 1) {
X dup2(p[1], 1);
X close(p[1]);
X }
X (*func)(fil);
X fflush(stdout);
X fflush(stderr);
X _exit(0);
X }
X close(p[1]);
X fclose(fil);
X str = afetch(fdpid,p[0],TRUE);
X str->str_u.str_useful = pipepid;
X return fdopen(p[0], "r");
X}
X
Xcryptswitch()
X{
X int ch;
X#ifdef STDSTDIO
X /* cheat on stdio if possible */
X if (rsfp->_cnt > 0 && (*rsfp->_ptr & 0xff) != CRYPT_MAGIC_1)
X return;
X#endif
X ch = getc(rsfp);
X if (ch == CRYPT_MAGIC_1) {
X if (getc(rsfp) == CRYPT_MAGIC_2) {
X rsfp = mypfiopen( rsfp, cryptfilter );
X preprocess = 1; /* force call to pclose when done */
X }
X else
X fatal( "bad encryption format" );
X }
X else
X ungetc(ch,rsfp);
X}
X
XFILE *
Xcryptopen(cmd) /* open a (possibly encrypted) program for input */
Xchar *cmd;
X{
X FILE *fil = fopen( cmd, "r" );
X
X lastpipefile = Nullfp;
X pipepid = 0;
X
X if( fil ) {
X int ch = getc( fil );
X int lines = 0;
X int chars = 0;
X
X /* Search for the magic cookie that starts the encrypted script,
X ** while still allowing a few lines of unencrypted text to let
X ** '#!' and the nih hack both continue to work. (These lines
X ** will end up being ignored.)
X */
X while( ch != CRYPT_MAGIC_1 && ch != EOF && lines < 5 && chars < 300 ) {
X if( ch == '\n' )
X ++lines;
X ch = getc( fil );
X ++chars;
X }
X
X if( ch == CRYPT_MAGIC_1 ) {
X if( (ch = getc( fil ) ) == CRYPT_MAGIC_2 ) {
X if( perldb ) fatal("can't debug an encrypted script");
X /* we found it, decrypt the rest of the file */
X fil = mypfiopen( fil, cryptfilter );
X return( lastpipefile = fil );
X } else
X /* if its got MAGIC 1 without MAGIC 2, too bad */
X fatal( "bad encryption format" );
X }
X
X /* this file is not encrypted - rewind and process it normally */
X rewind( fil );
X }
X
X return( fil );
X}
X
XVOID
Xcryptclose(fil)
XFILE *fil;
X{
X if( fil == Nullfp )
X return;
X
X if( fil == lastpipefile )
X mypclose( fil );
X else
X fclose( fil );
X}
X#endif /* !MSDOS */
X
X#endif /* CRYPTSCRIPT */
!STUFFY!FUNK!
echo Extracting perly.fixer
sed >perly.fixer <<'!STUFFY!FUNK!' -e 's/X//'
X#!/bin/sh
X
X# Hacks to make it work with Interactive's SysVr3 Version 2.2
X# doughera@lafvax.lafayette.edu (Andy Dougherty) 3/23/91
X
Xinput=$1
Xoutput=$2
Xtmp=/tmp/f$$
X
Xplan="unknown"
X
X# Test for BSD 4.3 version.
Xegrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
Xshort[ ]*yys\[ *YYMAXDEPTH *\] *;
Xyyps *= *&yys\[ *-1 *\];
Xyypv *= *&yyv\[ *-1 *\];
Xif *\( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
X
Xset `wc -l $tmp`
Xif test "$1" = "5"; then
X plan="bsd43"
Xfi
X
Xif test "$plan" = "unknown"; then
X # Test for ISC 2.2 version.
Xegrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
Xint[ ]*yys\[ *YYMAXDEPTH *\] *;
Xyyps *= *&yys\[ *-1 *\];
Xyypv *= *&yyv\[ *-1 *\];
Xif *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
X
X set `wc -l $tmp`
X if test "$1" = "5"; then
X plan="isc"
X fi
Xfi
X
Xcase "$plan" in
X #######################################################
X "bsd43")
X echo "Patching perly.c to allow dynamic yacc stack allocation"
X echo "Assuming bsd4.3 yaccpar"
X cat >$tmp <<'END'
X/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
Xint yymaxdepth = YYMAXDEPTH;\
XYYSTYPE *yyv; /* where the values are stored */\
Xshort *yys;\
Xshort *maxyyps;
X
X/short[ ]*yys\[ *YYMAXDEPTH *\] *;/d
X
X/yyps *= *&yys\[ *-1 *\];/d
X
X/yypv *= *&yyv\[ *-1 *\];/c\
X\ if (!yyv) {\
X\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
X\ yys = (short*) malloc(yymaxdepth * sizeof(short));\
X\ maxyyps = &yys[yymaxdepth];\
X\ }\
X\ yyps = &yys[-1];\
X\ yypv = &yyv[-1];
X
X
X/if *( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *)/c\
X\ if( ++yyps >= maxyyps ) {\
X\ int tv = yypv - yyv;\
X\ int ts = yyps - yys;\
X\
X\ yymaxdepth *= 2;\
X\ yyv = (YYSTYPE*)realloc((char*)yyv,\
X\ yymaxdepth*sizeof(YYSTYPE));\
X\ yys = (short*)realloc((char*)yys,\
X\ yymaxdepth*sizeof(short));\
X\ yyps = yys + ts;\
X\ yypv = yyv + tv;\
X\ maxyyps = &yys[yymaxdepth];\
X\ }
X
X/yacc stack overflow.*}/d
X/yacc stack overflow/,/}/d
XEND
X sed -f $tmp <$input >$output ;;
X
X #######################################################
X "isc") # Interactive Systems 2.2 version
X echo "Patching perly.c to allow dynamic yacc stack allocation"
X echo "Assuming Interactive SysVr3 2.2 yaccpar"
X # Easier to simply put whole script here than to modify the
X # bsd script with sed.
X # Main changes: yaccpar sometimes uses yy_ps and yy_pv
X # which are local register variables.
X # if(++yyps > YYMAXDEPTH) had opening brace on next line.
X # I've kept that brace in along with a call to yyerror if
X # realloc fails. (Actually, I just don't know how to do
X # multi-line matches in sed.)
X cat > $tmp << 'END'
X/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
Xint yymaxdepth = YYMAXDEPTH;\
XYYSTYPE *yyv; /* where the values are stored */\
Xint *yys;\
Xint *maxyyps;
X
X/int[ ]*yys\[ *YYMAXDEPTH *\] *;/d
X
X/yyps *= *&yys\[ *-1 *\];/d
X
X/yypv *= *&yyv\[ *-1 *\];/c\
X\ if (!yyv) {\
X\ yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
X\ yys = (int*) malloc(yymaxdepth * sizeof(int));\
X\ maxyyps = &yys[yymaxdepth];\
X\ }\
X\ yyps = &yys[-1];\
X\ yypv = &yyv[-1];
X
X/if *( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *)/c\
X\ if( ++yy_ps >= maxyyps ) {\
X\ int tv = yy_pv - yyv;\
X\ int ts = yy_ps - yys;\
X\
X\ yymaxdepth *= 2;\
X\ yyv = (YYSTYPE*)realloc((char*)yyv,\
X\ yymaxdepth*sizeof(YYSTYPE));\
X\ yys = (int*)realloc((char*)yys,\
X\ yymaxdepth*sizeof(int));\
X\ yy_ps = yyps = yys + ts;\
X\ yy_pv = yypv = yyv + tv;\
X\ maxyyps = &yys[yymaxdepth];\
X\ }\
X\ if (yyv == NULL || yys == NULL)
XEND
X sed -f $tmp < $input > $output ;;
X
X ######################################################
X # Plan still unknown
X *) mv $input $output;
Xesac
X
Xrm -rf $tmp $input
!STUFFY!FUNK!
echo Extracting msdos/popen.c
sed >msdos/popen.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: popen.c,v 4.0 91/03/20 01:34:50 lwall Locked $
X *
X * (C) Copyright 1988, 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: popen.c,v $
X * Revision 4.0 91/03/20 01:34:50 lwall
X * 4.0 baseline.
X *
X * Revision 3.0.1.2 90/08/09 04:04:42 lwall
X * patch19: various MSDOS and OS/2 patches folded in
X *
X * Revision 3.0.1.1 90/03/27 16:11:57 lwall
X * patch16: MSDOS support
X *
X * Revision 1.1 90/03/18 20:32:20 dds
X * Initial revision
X *
X */
X
X/*
X * Popen and pclose for MS-DOS
X */
X
X#include <stdlib.h>
X#include <stdio.h>
X#include <process.h>
X
X/*
X * Possible actions on an popened file
X */
Xenum action {
X delete, /* Used for "r". Delete the tmp file */
X execute /* Used for "w". Execute the command. */
X};
X
X/*
X * Linked list of things to do at the end of the program execution.
X */
Xstatic struct todo {
X FILE *f; /* File we are working on (to fclose) */
X const char *name; /* Name of the file (to unlink) */
X const char *command; /* Command to execute */
X enum action what; /* What to do (execute or delete) */
X struct todo *next; /* Next structure */
X} *todolist;
X
X
X/* Clean up function */
Xstatic int close_pipes(void);
X
X/*
X * Add a file f running the command command on file name to the list
X * of actions to be done at the end. The action is specified in what.
X * Return -1 on failure, 0 if ok.
X */
Xstatic int
Xadd(FILE *f, const char *command, const char *name, enum action what)
X{
X struct todo *p;
X
X if ((p = (struct todo *) malloc(sizeof(struct todo))) == NULL)
X return -1;
X p->f = f;
X p->command = command;
X p->name = name;
X p->what = what;
X p->next = todolist;
X todolist = p;
X return 0;
X}
X
XFILE *
Xmypopen(const char *command, const char *t)
X{
X char buff[256];
X char *name;
X FILE *f;
X static init = 0;
X
X if (!init)
X if (onexit(close_pipes) == NULL)
X return NULL;
X else
X init++;
X
X if ((name = tempnam((char*)NULL, "pp")) == NULL)
X return NULL;
X
X switch (*t) {
X case 'r':
X sprintf(buff, "%s >%s", command, name);
X if (system(buff) || (f = fopen(name, "r")) == NULL) {
X free(name);
X return NULL;
X }
X if (add(f, command, name, delete)) {
X (void)fclose(f);
X (void)unlink(name);
X free(name);
X return NULL;
X }
X return f;
X case 'w':
X if ((f = fopen(name, "w")) == NULL) {
X free(name);
X return NULL;
X }
X if (add(f, command, name, execute)) {
X (void)fclose(f);
X (void)unlink(name);
X free(name);
X return NULL;
X }
X return f;
X default:
X free(name);
X return NULL;
X }
X}
X
Xint
Xmypclose(FILE *f)
X{
X struct todo *p, **prev;
X char buff[256];
X const char *name;
X int status;
X
X for (p = todolist, prev = &todolist; p; prev = &(p->next), p = p->next)
X if (p->f == f) {
X *prev = p->next;
X name = p->name;
X switch (p->what) {
X case delete:
X free(p);
X if (fclose(f) == EOF) {
X (void)unlink(name);
X status = EOF;
X } else if (unlink(name) < 0)
X status = EOF;
X else
X status = 0;
X free((void*)name);
X return status;
X case execute:
X (void)sprintf(buff, "%s <%s", p->command, p->name);
X free(p);
X if (fclose(f) == EOF) {
X (void)unlink(name);
X status = EOF;
X } else if (system(buff)) {
X (void)unlink(name);
X status = EOF;
X } else if (unlink(name) < 0)
X status = EOF;
X else
X status = 0;
X free((void*)name);
X return status;
X default:
X return EOF;
X }
X }
X return EOF;
X}
X
X/*
X * Clean up at the end. Called by the onexit handler.
X */
Xstatic int
Xclose_pipes(void)
X{
X struct todo *p;
X
X for (p = todolist; p; p = p->next)
X (void)mypclose(p->f);
X return 0;
X}
!STUFFY!FUNK!
echo Extracting lib/termcap.pl
sed >lib/termcap.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header: termcap.pl,v 4.0 91/03/20 01:26:33 lwall Locked $
X;#
X;# Usage:
X;# require 'ioctl.pl';
X;# ioctl(TTY,$TIOCGETP,$foo);
X;# ($ispeed,$ospeed) = unpack('cc',$foo);
X;# require 'termcap.pl';
X;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
X;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
X;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
X;#
Xsub Tgetent {
X local($TERM) = @_;
X local($TERMCAP,$_,$entry,$loop,$field);
X
X warn "Tgetent: no ospeed set" unless $ospeed;
X foreach $key (keys(TC)) {
X delete $TC{$key};
X }
X $TERM = $ENV{'TERM'} unless $TERM;
X $TERMCAP = $ENV{'TERMCAP'};
X $TERMCAP = '/etc/termcap' unless $TERMCAP;
X if ($TERMCAP !~ m:^/:) {
X if (index($TERMCAP,"|$TERM|") < $[) {
X $TERMCAP = '/etc/termcap';
X }
X }
X if ($TERMCAP =~ m:^/:) {
X $entry = '';
X do {
X $loop = "
X open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
X while (<TERMCAP>) {
X next if /^#/;
X next if /^\t/;
X if (/\\|$TERM[:\\|]/) {
X chop;
X while (chop eq '\\\\') {
X \$_ .= <TERMCAP>;
X chop;
X }
X \$_ .= ':';
X last;
X }
X }
X close TERMCAP;
X \$entry .= \$_;
X ";
X eval $loop;
X } while s/:tc=([^:]+):/:/ && ($TERM = $1);
X $TERMCAP = $entry;
X }
X
X foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
X if ($field =~ /^\w\w$/) {
X $TC{$field} = 1;
X }
X elsif ($field =~ /^(\w\w)#(.*)/) {
X $TC{$1} = $2 if $TC{$1} eq '';
X }
X elsif ($field =~ /^(\w\w)=(.*)/) {
X $entry = $1;
X $_ = $2;
X s/\\E/\033/g;
X s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
X s/\\n/\n/g;
X s/\\r/\r/g;
X s/\\t/\t/g;
X s/\\b/\b/g;
X s/\\f/\f/g;
X s/\\\^/\377/g;
X s/\^\?/\177/g;
X s/\^(.)/pack('c',ord($1) & 31)/eg;
X s/\\(.)/$1/g;
X s/\377/^/g;
X $TC{$entry} = $_ if $TC{$entry} eq '';
X }
X }
X $TC{'pc'} = "\0" if $TC{'pc'} eq '';
X $TC{'bc'} = "\b" if $TC{'bc'} eq '';
X}
X
X@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
X
Xsub Tputs {
X local($string,$affcnt,$FH) = @_;
X local($ms);
X if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
X $ms = $1;
X $ms *= $affcnt if $2;
X $string = $3;
X $decr = $Tputs[$ospeed];
X if ($decr > .1) {
X $ms += $decr / 2;
X $string .= $TC{'pc'} x ($ms / $decr);
X }
X }
X print $FH $string if $FH;
X $string;
X}
X
Xsub Tgoto {
X local($string) = shift(@_);
X local($result) = '';
X local($after) = '';
X local($code,$tmp) = @_;
X local(@tmp);
X @tmp = ($tmp,$code);
X local($online) = 0;
X while ($string =~ /^([^%]*)%(.)(.*)/) {
X $result .= $1;
X $code = $2;
X $string = $3;
X if ($code eq 'd') {
X $result .= sprintf("%d",shift(@tmp));
X }
X elsif ($code eq '.') {
X $tmp = shift(@tmp);
X if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
X if ($online) {
X ++$tmp, $after .= $TC{'up'} if $TC{'up'};
X }
X else {
X ++$tmp, $after .= $TC{'bc'};
X }
X }
X $result .= sprintf("%c",$tmp);
X $online = !$online;
X }
X elsif ($code eq '+') {
X $result .= sprintf("%c",shift(@tmp)+ord($string));
X $string = substr($string,1,99);
X $online = !$online;
X }
X elsif ($code eq 'r') {
X ($code,$tmp) = @tmp;
X @tmp = ($tmp,$code);
X $online = !$online;
X }
X elsif ($code eq '>') {
X ($code,$tmp,$string) = unpack("CCa99",$string);
X if ($tmp[$[] > $code) {
X $tmp[$[] += $tmp;
X }
X }
X elsif ($code eq '2') {
X $result .= sprintf("%02d",shift(@tmp));
X $online = !$online;
X }
X elsif ($code eq '3') {
X $result .= sprintf("%03d",shift(@tmp));
X $online = !$online;
X }
X elsif ($code eq 'i') {
X ($code,$tmp) = @tmp;
X @tmp = ($code+1,$tmp+1);
X }
X else {
X return "OOPS";
X }
X }
X $result . $string . $after;
X}
X
X1;
!STUFFY!FUNK!
echo Extracting t/cmd/subval.t
sed >t/cmd/subval.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: subval.t,v 4.0 91/03/20 01:49:40 lwall Locked $
X
Xsub foo1 {
X 'true1';
X if ($_[0]) { 'true2'; }
X}
X
Xsub foo2 {
X 'true1';
X if ($_[0]) { return 'true2'; } else { return 'true3'; }
X 'true0';
X}
X
Xsub foo3 {
X 'true1';
X unless ($_[0]) { 'true2'; }
X}
X
Xsub foo4 {
X 'true1';
X unless ($_[0]) { 'true2'; } else { 'true3'; }
X}
X
Xsub foo5 {
X 'true1';
X 'true2' if $_[0];
X}
X
Xsub foo6 {
X 'true1';
X 'true2' unless $_[0];
X}
X
Xprint "1..34\n";
X
Xif (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
Xif (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
Xif (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
Xif (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
X
Xif (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
Xif (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
Xif (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
Xif (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
X
Xif (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
Xif (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
Xif (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
Xif (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
X
X# Now test to see that recursion works using a Fibonacci number generator
X
Xsub fib {
X local($arg) = @_;
X local($foo);
X $level++;
X if ($arg <= 2) {
X $foo = 1;
X }
X else {
X $foo = do fib($arg-1) + do fib($arg-2);
X }
X $level--;
X $foo;
X}
X
X@good = (0,1,1,2,3,5,8,13,21,34,55,89);
X
Xfor ($i = 1; $i <= 10; $i++) {
X $foo = $i + 12;
X if (do fib($i) == $good[$i]) {
X print "ok $foo\n";
X }
X else {
X print "not ok $foo\n";
X }
X}
X
Xsub ary1 {
X (1,2,3);
X}
X
Xprint &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
X
Xprint join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
X
Xsub ary2 {
X do {
X return (1,2,3);
X (3,2,1);
X };
X 0;
X}
X
Xprint &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
X
X$x = join(':',&ary2);
Xprint $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
X
Xsub somesub {
X local($num,$P,$F,$L) = @_;
X ($p,$f,$l) = caller;
X print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num\n";
X}
X
X&somesub(27, 'main', __FILE__, __LINE__);
X
Xpackage foo;
X&main'somesub(28, 'foo', __FILE__, __LINE__);
X
Xpackage main;
X$i = 28;
Xopen(FOO,">Cmd_subval.tmp");
Xprint FOO "blah blah\n";
Xclose FOO;
X
X&file_main(*F);
Xclose F;
X&info_main;
X
X&file_package(*F);
Xclose F;
X&info_package;
X
Xunlink 'Cmd_subval.tmp';
X
Xsub file_main {
X local(*F) = @_;
X
X open(F, 'Cmd_subval.tmp') || die "can't open\n";
X $i++;
X eof F ? print "not ok $i\n" : print "ok $i\n";
X}
X
Xsub info_main {
X local(*F);
X
X open(F, 'Cmd_subval.tmp') || die "test: can't open\n";
X $i++;
X eof F ? print "not ok $i\n" : print "ok $i\n";
X &iseof(*F);
X close F;
X}
X
Xsub iseof {
X local(*UNIQ) = @_;
X
X $i++;
X eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n";
X}
X
X{package foo;
X
X sub main'file_package {
X local(*F) = @_;
X
X open(F, 'Cmd_subval.tmp') || die "can't open\n";
X $main'i++;
X eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
X }
X
X sub main'info_package {
X local(*F);
X
X open(F, 'Cmd_subval.tmp') || die "can't open\n";
X $main'i++;
X eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
X &iseof(*F);
X }
X
X sub iseof {
X local(*UNIQ) = @_;
X
X $main'i++;
X eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n";
X }
X}
!STUFFY!FUNK!
echo Extracting t/op/pat.t
sed >t/op/pat.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: pat.t,v 4.0 91/03/20 01:54:01 lwall Locked $
X
Xprint "1..43\n";
X
X$x = "abc\ndef\n";
X
Xif ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
Xif ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
X
X$* = 1;
Xif ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
X$* = 0;
X
X$_ = '123';
Xif (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
X
Xif ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
Xif ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
X
Xif ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
Xif ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
X
Xif ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
Xif ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
X
Xif ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
Xif ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
X
X$_ = 'aaabbbccc';
Xif (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
X print "ok 13\n";
X} else {
X print "not ok 13\n";
X}
Xif (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
X print "ok 14\n";
X} else {
X print "not ok 14\n";
X}
X
Xif (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
X
X$_ = 'aaabccc';
Xif (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
Xif (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
X
X$_ = 'aaaccc';
Xif (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
Xif (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
X
X$_ = 'abcdef';
Xif (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
Xif (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
X
Xif (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
X
Xif (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
X
X$* = 1; # test 3 only tested the optimized version--this one is for real
Xif ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
X$* = 0;
X
X$XXX{123} = 123;
X$XXX{234} = 234;
X$XXX{345} = 345;
X
X@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
Xwhile ($_ = shift(XXX)) {
X ?(.*)? && (print $1,"\n");
X /not/ && reset;
X /not ok 26/ && reset 'X';
X}
X
Xwhile (($key,$val) = each(XXX)) {
X print "not ok 27\n";
X exit;
X}
X
Xprint "ok 27\n";
X
X'cde' =~ /[^ab]*/;
X'xyz' =~ //;
Xif ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
X
X$foo = '[^ab]*';
X'cde' =~ /$foo/;
X'xyz' =~ //;
Xif ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
X
X$foo = '[^ab]*';
X'cde' =~ /$foo/;
X'xyz' =~ /$null/;
Xif ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
X
X$_ = 'abcdefghi';
X/def/; # optimized up to cmd
Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
X
X/cde/ + 0; # optimized only to spat
Xif ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
X
X/[d][e][f]/; # not optimized
Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
X
X$_ = 'now is the {time for all} good men to come to.';
X/ {([^}]*)}/;
Xif ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
X
X$_ = 'xxx {3,4} yyy zzz';
Xprint /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
Xprint $1 eq ' ' ? "ok 36\n" : "not ok 36\n";
Xprint /( {4,})/ ? "not ok 37\n" : "ok 37\n";
Xprint /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
Xprint $1 eq ' y' ? "ok 39\n" : "not ok 39\n";
Xprint /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
Xprint $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
Xprint /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
Xprint /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
!STUFFY!FUNK!
echo Extracting handy.h
sed >handy.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: handy.h,v 4.0 91/03/20 01:22:15 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 4.0 91/03/20 01:22:15 lwall
X * 4.0 baseline.
X *
X */
X
X#ifdef NULL
X#undef NULL
X#endif
X#ifndef I286
X# define NULL 0
X#else
X# define NULL 0L
X#endif
X#define Null(type) ((type)NULL)
X#define Nullch Null(char*)
X#define Nullfp Null(FILE*)
X
X#ifdef UTS
X#define bool int
X#else
X#define bool char
X#endif
X
X#ifdef TRUE
X#undef TRUE
X#endif
X#ifdef FALSE
X#undef FALSE
X#endif
X#define TRUE (1)
X#define FALSE (0)
X
X#define Ctl(ch) (ch & 037)
X
X#define strNE(s1,s2) (strcmp(s1,s2))
X#define strEQ(s1,s2) (!strcmp(s1,s2))
X#define strLT(s1,s2) (strcmp(s1,s2) < 0)
X#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
X#define strGT(s1,s2) (strcmp(s1,s2) > 0)
X#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
X#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
X#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
X
X#define MEM_SIZE unsigned int
X
X/* Line numbers are unsigned, 16 bits. */
Xtypedef unsigned short line_t;
X#ifdef lint
X#define NOLINE ((line_t)0)
X#else
X#define NOLINE ((line_t) 65535)
X#endif
X
X#ifndef lint
X#ifndef LEAKTEST
Xchar *safemalloc();
Xchar *saferealloc();
Xvoid safefree();
X#ifndef MSDOS
X#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
X#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
X#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \
X bzero((char*)(v), (n) * sizeof(t))
X#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#else
X#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t))))
X#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t))))
X#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \
X bzero((char*)(v), (n) * sizeof(t))
X#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
X#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
X#endif /* MSDOS */
X#define Safefree(d) safefree((char*)d)
X#define Str_new(x,len) str_new(len)
X#else /* LEAKTEST */
Xchar *safexmalloc();
Xchar *safexrealloc();
Xvoid safexfree();
X#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
X#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
X#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \
X bzero((char*)(v), (n) * sizeof(t))
X#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
X#define Safefree(d) safexfree((char*)d)
X#define Str_new(x,len) str_new(x,len)
X#define MAXXCOUNT 1200
Xlong xcount[MAXXCOUNT];
Xlong lastxcount[MAXXCOUNT];
X#endif /* LEAKTEST */
X#define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t))
X#define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t))
X#else /* lint */
X#define New(x,v,n,s) (v = Null(s *))
X#define Newc(x,v,n,s,c) (v = Null(s *))
X#define Newz(x,v,n,s) (v = Null(s *))
X#define Renew(v,n,s) (v = Null(s *))
X#define Copy(s,d,n,t)
X#define Zero(d,n,t)
X#define Safefree(d) d = d
X#endif /* lint */
!STUFFY!FUNK!
echo Extracting usub/pager
sed >usub/pager <<'!STUFFY!FUNK!' -e 's/X//'
X#!./curseperl
X
Xeval <<'EndOfMain'; $evaloffset = __LINE__;
X
X $SIG{'INT'} = 'endit';
X $| = 1; # command buffering on stdout
X &initterm;
X &inithelp;
X &slurpfile && &pagearray;
X
XEndOfMain
X
X&endit;
X
X################################################################################
X
Xsub initterm {
X
X &initscr; &cbreak; &noecho; &scrollok($stdscr, 1);
X &defbell unless defined &bell;
X
X $lines = $LINES; $lines1 = $lines - 1; $lines2 = $lines - 2;
X $cols = $COLS; $cols1 = $cols - 1; $cols2 = $cols - 2;;
X
X $dl = &getcap('dl');
X $al = &getcap('al');
X $ho = &getcap('ho');
X $ce = &getcap('ce');
X}
X
Xsub slurpfile {
X while (<>) {
X s/^(\t+)/' ' x length($1)/e;
X &expand($_) if /\t/;
X if (length($_) < $cols) {
X push(@lines, $_);
X }
X else {
X while ($_ && $_ ne "\n") {
X push(@lines, substr($_,0,$cols));
X substr($_,0,$cols) = '';
X }
X }
X }
X 1;
X}
X
Xsub drawscreen {
X &move(0,0);
X for ($line .. $line + $lines2) {
X &addstr($lines[$_]);
X }
X &clrtobot;
X &percent;
X &refresh;
X}
X
Xsub expand {
X while (($off = index($_[0],"\t")) >= 0) {
X substr($_[0], $off, 1) = ' ' x (8 - $off % 8);
X }
X}
X
Xsub pagearray {
X $line = 0;
X
X $| = 1;
X
X for (&drawscreen;;&drawscreen) {
X
X $ch = &getch;
X $ch = 'j' if $ch eq "\n";
X
X if ($ch eq ' ') {
X last if $percent >= 100;
X &move(0,0);
X $line += $lines1;
X }
X elsif ($ch eq 'b') {
X $line -= $lines1;
X &move(0,0);
X $line = 0 if $line < 0;
X }
X elsif ($ch eq 'j') {
X next if $percent >= 100;
X $line += 1;
X if ($dl && $ho) {
X print $ho, $dl;
X &mvcur(0,0,$lines2,0);
X print $ce,$lines[$line+$lines2],$ce;
X &wmove($curscr,0,0);
X &wdeleteln($curscr);
X &wmove($curscr,$lines2,0);
X &waddstr($curscr,$lines[$line+$lines2]);
X }
X &wmove($stdscr,0,0);
X &wdeleteln($stdscr);
X &wmove($stdscr,$lines2,0);
X &waddstr($stdscr,$lines[$line+$lines2]);
X &percent;
X &refresh;
X redo;
X }
X elsif ($ch eq 'k') {
X next if $line <= 0;
X $line -= 1;
X if ($al && $ho && $ce) {
X print $ho, $al, $ce, $lines[$line];
X &wmove($curscr,0,0);
X &winsertln($curscr);
X &waddstr($curscr,$lines[$line]);
X }
X &wmove($stdscr,0,0);
X &winsertln($stdscr);
X &waddstr($stdscr,$lines[$line]);
X &percent;
X &refresh;
X redo;
X }
X elsif ($ch eq "\f") {
X &clear;
X }
X elsif ($ch eq 'q') {
X last;
X }
X elsif ($ch eq 'h') {
X &clear;
X &help;
X &clear;
X }
X else {
X &bell;
X }
X }
X}
X
Xsub defbell {
X eval q#
X sub bell {
X print "\007";
X }
X #;
X}
X
Xsub help {
X local(*lines) = *helplines;
X local($line);
X &pagearray;
X}
X
Xsub inithelp {
X @helplines = split(/\n/,<<'EOT');
X
X h Display this help.
X q Exit.
X
X SPACE Forward screen.
X b Backward screen.
X j, CR Forward 1 line.
X k Backward 1 line.
X FF Repaint screen.
XEOT
X for (@helplines) {
X s/$/\n/;
X }
X}
X
Xsub percent {
X &standout;
X $percent = int(($line + $lines1) * 100 / @lines);
X &move($lines1,0);
X &addstr("($percent%)");
X &standend;
X &clrtoeol;
X}
X
Xsub endit {
X &move($lines1,0);
X &clrtoeol;
X &refresh;
X &endwin;
X
X if ($@) {
X print ""; # force flush of stdout
X $@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e;
X die $@;
X }
X
X exit;
X}
!STUFFY!FUNK!
echo Extracting msdos/chdir.c
sed >msdos/chdir.c <<'!STUFFY!FUNK!' -e 's/X//'
X/*
X * (C) Copyright 1990, 1991 Tom Dinger
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 4.0 kit.
X *
X */
X
X/*
X * A "DOS-aware" chdir() function, that will change current drive as well.
X *
X * chdir( "B:" ) -- changes to the default directory, on drive B:
X * chdir( "C:\FOO" ) changes to the specified directory, on drive C:
X * chdir( "\BAR" ) changes to the specified directory on the current
X * drive.
X */
X
X#include <stdlib.h>
X#include <ctype.h>
X#include <direct.h>
X#include <dos.h>
X#include <errno.h>
X
X#include "config.h"
X#ifdef chdir
X#undef chdir
X#endif
X
X/* We should have the line:
X *
X * #define chdir perl_chdir
X *
X * in some header for perl (I put it in config.h) so that all
X * references to chdir() become references to this function.
X */
X
X/*------------------------------------------------------------------*/
X
X#if defined(BUGGY_MSC5) /* only needed for MSC 5.1 */
X
Xint _chdrive( int drivenum )
X{
Xunsigned int ndrives;
Xunsigned int tmpdrive;
X
X
X_dos_setdrive( drivenum, &ndrives );
X
X/* check for illegal drive letter */
X_dos_getdrive( &tmpdrive );
X
Xreturn (tmpdrive != drivenum) ? -1 : 0 ;
X}
X
X#endif
X
X/*-----------------------------------------------------------------*/
X
Xint perl_chdir( char * path )
X{
Xint drive_letter;
Xunsigned int drivenum;
X
X
Xif ( path && *path && (path[1] == ':') )
X {
X /* The path starts with a drive letter */
X /* Change current drive */
X drive_letter = *path;
X if ( isalpha(drive_letter) )
X {
X /* Drive letter legal */
X if ( islower(drive_letter) )
X drive_letter = toupper(drive_letter);
X drivenum = drive_letter - 'A' + 1;
X
X /* Change drive */
X if ( _chdrive( drivenum ) == -1 )
X {
X /* Drive change failed -- must be illegal drive letter */
X errno = ENODEV;
X return -1;
X }
X
X /* Now see if that's all we do */
X if ( ! path[2] )
X return 0; /* no path after drive -- all done */
X }
X /* else drive letter illegal -- fall into "normal" chdir */
X }
X
X/* Here with some path as well */
Xreturn chdir( path );
X
X/* end perl_chdir() */
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 32 (of 36)"
cat /dev/null >kit32isdone
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.
