lwall@netlabs.com (Larry Wall) (04/18/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 46
Archive-name: perl/part28
[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 28 (of 36). If kit 28 is complete, the line"
echo '"'"End of kit 28 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir lib os2 2>/dev/null
echo Extracting os2/s2p.cmd
sed >os2/s2p.cmd <<'!STUFFY!FUNK!' -e 's/X//'
Xextproc perl -Sx
X#!perl
X
X$bin = 'c:/bin';
X
X# $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
X#
X# $Log: s2p.cmd,v $
X# Revision 4.0 91/03/20 01:37:09 lwall
X# 4.0 baseline.
X#
X# Revision 3.0.1.6 90/10/20 02:21:43 lwall
X# patch37: changed some ". config.sh" to ". ./config.sh"
X#
X# Revision 3.0.1.5 90/10/16 11:32:40 lwall
X# patch29: s2p modernized
X#
X# Revision 3.0.1.4 90/08/09 05:50:43 lwall
X# patch19: s2p didn't translate \n right
X#
X# Revision 3.0.1.3 90/03/01 10:31:21 lwall
X# patch9: s2p didn't handle \< and \>
X#
X# Revision 3.0.1.2 89/11/17 15:51:27 lwall
X# patch5: in s2p, line labels without a subsequent statement were done wrong
X# patch5: s2p left residue in /tmp
X#
X# Revision 3.0.1.1 89/11/11 05:08:25 lwall
X# patch2: in s2p, + within patterns needed backslashing
X# patch2: s2p was printing out some debugging info to the output file
X#
X# Revision 3.0 89/10/18 15:35:02 lwall
X# 3.0 baseline
X#
X# Revision 2.0.1.1 88/07/11 23:26:23 root
X# patch2: s2p didn't put a proper prologue on output script
X#
X# Revision 2.0 88/06/05 00:15:55 root
X# Baseline version 2.0.
X#
X#
X
X$indent = 4;
X$shiftwidth = 4;
X$l = '{'; $r = '}';
X
Xwhile ($ARGV[0] =~ /^-/) {
X $_ = shift;
X last if /^--/;
X if (/^-D/) {
X $debug++;
X open(BODY,'>-');
X next;
X }
X if (/^-n/) {
X $assumen++;
X next;
X }
X if (/^-p/) {
X $assumep++;
X next;
X }
X die "I don't recognize this switch: $_\n";
X}
X
Xunless ($debug) {
X open(BODY,">sperl$$") ||
X &Die("Can't open temp file: $!\n");
X}
X
Xif (!$assumen && !$assumep) {
X print BODY <<'EOT';
Xwhile ($ARGV[0] =~ /^-/) {
X $_ = shift;
X last if /^--/;
X if (/^-n/) {
X $nflag++;
X next;
X }
X die "I don't recognize this switch: $_\\n";
X}
X
XEOT
X}
X
Xprint BODY <<'EOT';
X
X#ifdef PRINTIT
X#ifdef ASSUMEP
X$printit++;
X#else
X$printit++ unless $nflag;
X#endif
X#endif
XLINE: while (<>) {
XEOT
X
XLINE: while (<>) {
X
X # Wipe out surrounding whitespace.
X
X s/[ \t]*(.*)\n$/$1/;
X
X # Perhaps it's a label/comment.
X
X if (/^:/) {
X s/^:[ \t]*//;
X $label = &make_label($_);
X if ($. == 1) {
X $toplabel = $label;
X }
X $_ = "$label:";
X if ($lastlinewaslabel++) {
X $indent += 4;
X print BODY &tab, ";\n";
X $indent -= 4;
X }
X if ($indent >= 2) {
X $indent -= 2;
X $indmod = 2;
X }
X next;
X } else {
X $lastlinewaslabel = '';
X }
X
X # Look for one or two address clauses
X
X $addr1 = '';
X $addr2 = '';
X if (s/^([0-9]+)//) {
X $addr1 = "$1";
X }
X elsif (s/^\$//) {
X $addr1 = 'eof()';
X }
X elsif (s|^/||) {
X $addr1 = &fetchpat('/');
X }
X if (s/^,//) {
X if (s/^([0-9]+)//) {
X $addr2 = "$1";
X } elsif (s/^\$//) {
X $addr2 = "eof()";
X } elsif (s|^/||) {
X $addr2 = &fetchpat('/');
X } else {
X &Die("Invalid second address at line $.\n");
X }
X $addr1 .= " .. $addr2";
X }
X
X # Now we check for metacommands {, }, and ! and worry
X # about indentation.
X
X s/^[ \t]+//;
X # a { to keep vi happy
X if ($_ eq '}') {
X $indent -= 4;
X next;
X }
X if (s/^!//) {
X $if = 'unless';
X $else = "$r else $l\n";
X } else {
X $if = 'if';
X $else = '';
X }
X if (s/^{//) { # a } to keep vi happy
X $indmod = 4;
X $redo = $_;
X $_ = '';
X $rmaybe = '';
X } else {
X $rmaybe = "\n$r";
X if ($addr2 || $addr1) {
X $space = ' ' x $shiftwidth;
X } else {
X $space = '';
X }
X $_ = &transmogrify();
X }
X
X # See if we can optimize to modifier form.
X
X if ($addr1) {
X if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
X $_ !~ / if / && $_ !~ / unless /) {
X s/;$/ $if $addr1;/;
X $_ = substr($_,$shiftwidth,1000);
X } else {
X $_ = "$if ($addr1) $l\n$change$_$rmaybe";
X }
X $change = '';
X next LINE;
X }
X} continue {
X @lines = split(/\n/,$_);
X for (@lines) {
X unless (s/^ *<<--//) {
X print BODY &tab;
X }
X print BODY $_, "\n";
X }
X $indent += $indmod;
X $indmod = 0;
X if ($redo) {
X $_ = $redo;
X $redo = '';
X redo LINE;
X }
X}
Xif ($lastlinewaslabel++) {
X $indent += 4;
X print BODY &tab, ";\n";
X $indent -= 4;
X}
X
Xprint BODY "}\n";
Xif ($appendseen || $tseen || !$assumen) {
X $printit++ if $dseen || (!$assumen && !$assumep);
X print BODY <<'EOT';
X
Xcontinue {
X#ifdef PRINTIT
X#ifdef DSEEN
X#ifdef ASSUMEP
X print if $printit++;
X#else
X if ($printit)
X { print; }
X else
X { $printit++ unless $nflag; }
X#endif
X#else
X print if $printit;
X#endif
X#else
X print;
X#endif
X#ifdef TSEEN
X $tflag = '';
X#endif
X#ifdef APPENDSEEN
X if ($atext) { print $atext; $atext = ''; }
X#endif
X}
XEOT
X}
X
Xclose BODY;
X
Xunless ($debug) {
X open(HEAD,">sperl2$$.c")
X || &Die("Can't open temp file 2: $!\n");
X print HEAD "#define PRINTIT\n" if ($printit);
X print HEAD "#define APPENDSEEN\n" if ($appendseen);
X print HEAD "#define TSEEN\n" if ($tseen);
X print HEAD "#define DSEEN\n" if ($dseen);
X print HEAD "#define ASSUMEN\n" if ($assumen);
X print HEAD "#define ASSUMEP\n" if ($assumep);
X if ($opens) {print HEAD "$opens\n";}
X open(BODY,"sperl$$")
X || &Die("Can't reopen temp file: $!\n");
X while (<BODY>) {
X print HEAD $_;
X }
X close HEAD;
X
X print <<"EOT";
X#!$bin/perl
Xeval 'exec $bin/perl -S \$0 \$*'
X if \$running_under_some_shell;
X
XEOT
X open(BODY,"cc -E sperl2$$.c |") ||
X &Die("Can't reopen temp file: $!\n");
X while (<BODY>) {
X /^# [0-9]/ && next;
X /^[ \t]*$/ && next;
X s/^<><>//;
X print;
X }
X}
X
X&Cleanup;
Xexit;
X
Xsub Cleanup {
X unlink "sperl$$", "sperl2$$", "sperl2$$.c";
X}
Xsub Die {
X &Cleanup;
X die $_[0];
X}
Xsub tab {
X "\t" x ($indent / 8) . ' ' x ($indent % 8);
X}
Xsub make_filehandle {
X local($_) = $_[0];
X local($fname) = $_;
X s/[^a-zA-Z]/_/g;
X s/^_*//;
X substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
X if (!$seen{$_}) {
X $opens .= <<"EOT";
Xopen($_,'>$fname') || die "Can't create $fname";
XEOT
X }
X $seen{$_} = $_;
X}
X
Xsub make_label {
X local($label) = @_;
X $label =~ s/[^a-zA-Z0-9]/_/g;
X if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
X $label = substr($label,0,8);
X
X # Could be a reserved word, so capitalize it.
X substr($label,0,1) =~ y/a-z/A-Z/
X if $label =~ /^[a-z]/;
X
X $label;
X}
X
Xsub transmogrify {
X { # case
X if (/^d/) {
X $dseen++;
X chop($_ = <<'EOT');
X<<--#ifdef PRINTIT
X$printit = '';
X<<--#endif
Xnext LINE;
XEOT
X next;
X }
X
X if (/^n/) {
X chop($_ = <<'EOT');
X<<--#ifdef PRINTIT
X<<--#ifdef DSEEN
X<<--#ifdef ASSUMEP
Xprint if $printit++;
X<<--#else
Xif ($printit)
X { print; }
Xelse
X { $printit++ unless $nflag; }
X<<--#endif
X<<--#else
Xprint if $printit;
X<<--#endif
X<<--#else
Xprint;
X<<--#endif
X<<--#ifdef APPENDSEEN
Xif ($atext) {print $atext; $atext = '';}
X<<--#endif
X$_ = <>;
X<<--#ifdef TSEEN
X$tflag = '';
X<<--#endif
XEOT
X next;
X }
X
X if (/^a/) {
X $appendseen++;
X $command = $space . '$atext .=' . "\n<<--'";
X $lastline = 0;
X while (<>) {
X s/^[ \t]*//;
X s/^[\\]//;
X unless (s|\\$||) { $lastline = 1;}
X s/'/\\'/g;
X s/^([ \t]*\n)/<><>$1/;
X $command .= $_;
X $command .= '<<--';
X last if $lastline;
X }
X $_ = $command . "';";
X last;
X }
X
X if (/^[ic]/) {
X if (/^c/) { $change = 1; }
X $addr1 = '$iter = (' . $addr1 . ')';
X $command = $space . 'if ($iter == 1) { print'
X . "\n<<--'";
X $lastline = 0;
X while (<>) {
X s/^[ \t]*//;
X s/^[\\]//;
X unless (s/\\$//) { $lastline = 1;}
X s/'/\\'/g;
X s/^([ \t]*\n)/<><>$1/;
X $command .= $_;
X $command .= '<<--';
X last if $lastline;
X }
X $_ = $command . "';}";
X if ($change) {
X $dseen++;
X $change = "$_\n";
X chop($_ = <<"EOT");
X<<--#ifdef PRINTIT
X$space\$printit = '';
X<<--#endif
X${space}next LINE;
XEOT
X }
X last;
X }
X
X if (/^s/) {
X $delim = substr($_,1,1);
X $len = length($_);
X $repl = $end = 0;
X $inbracket = 0;
X for ($i = 2; $i < $len; $i++) {
X $c = substr($_,$i,1);
X if ($c eq $delim) {
X if ($inbracket) {
X substr($_, $i, 0) = '\\';
X $i++;
X $len++;
X }
X else {
X if ($repl) {
X $end = $i;
X last;
X } else {
X $repl = $i;
X }
X }
X }
X elsif ($c eq '\\') {
X $i++;
X if ($i >= $len) {
X $_ .= 'n';
X $_ .= <>;
X $len = length($_);
X $_ = substr($_,0,--$len);
X }
X elsif (substr($_,$i,1) =~ /^[n]$/) {
X ;
X }
X elsif (!$repl &&
X substr($_,$i,1) =~ /^[(){}\w]$/) {
X $i--;
X $len--;
X substr($_, $i, 1) = '';
X }
X elsif (!$repl &&
X substr($_,$i,1) =~ /^[<>]$/) {
X substr($_,$i,1) = 'b';
X }
X }
X elsif ($c eq '[' && !$repl) {
X $i++ if substr($_,$i,1) eq '^';
X $i++ if substr($_,$i,1) eq ']';
X $inbracket = 1;
X }
X elsif ($c eq ']') {
X $inbracket = 0;
X }
X elsif (!$repl && index("()+",$c) >= 0) {
X substr($_, $i, 0) = '\\';
X $i++;
X $len++;
X }
X }
X &Die("Malformed substitution at line $.\n")
X unless $end;
X $pat = substr($_, 0, $repl + 1);
X $repl = substr($_, $repl+1, $end-$repl-1);
X $end = substr($_, $end + 1, 1000);
X $dol = '$';
X $repl =~ s/\$/\\$/;
X $repl =~ s'&'$&'g;
X $repl =~ s/[\\]([0-9])/$dol$1/g;
X $subst = "$pat$repl$delim";
X $cmd = '';
X while ($end) {
X if ($end =~ s/^g//) {
X $subst .= 'g';
X next;
X }
X if ($end =~ s/^p//) {
X $cmd .= ' && (print)';
X next;
X }
X if ($end =~ s/^w[ \t]*//) {
X $fh = &make_filehandle($end);
X $cmd .= " && (print $fh \$_)";
X $end = '';
X next;
X }
X &Die("Unrecognized substitution command".
X "($end) at line $.\n");
X }
X chop ($_ = <<"EOT");
X<<--#ifdef TSEEN
X$subst && \$tflag++$cmd;
X<<--#else
X$subst$cmd;
X<<--#endif
XEOT
X next;
X }
X
X if (/^p/) {
X $_ = 'print;';
X next;
X }
X
X if (/^w/) {
X s/^w[ \t]*//;
X $fh = &make_filehandle($_);
X $_ = "print $fh \$_;";
X next;
X }
X
X if (/^r/) {
X $appendseen++;
X s/^r[ \t]*//;
X $file = $_;
X $_ = "\$atext .= `cat $file 2>/dev/null`;";
X next;
X }
X
X if (/^P/) {
X $_ = 'print $1 if /(^.*\n)/;';
X next;
X }
X
X if (/^D/) {
X chop($_ = <<'EOT');
Xs/^.*\n//;
Xredo LINE if $_;
Xnext LINE;
XEOT
X next;
X }
X
X if (/^N/) {
X chop($_ = <<'EOT');
X$_ .= <>;
X<<--#ifdef TSEEN
X$tflag = '';
X<<--#endif
XEOT
X next;
X }
X
X if (/^h/) {
X $_ = '$hold = $_;';
X next;
X }
X
X if (/^H/) {
X $_ = '$hold .= $_ ? $_ : "\n";';
X next;
X }
X
X if (/^g/) {
X $_ = '$_ = $hold;';
X next;
X }
X
X if (/^G/) {
X $_ = '$_ .= $hold ? $hold : "\n";';
X next;
X }
X
X if (/^x/) {
X $_ = '($_, $hold) = ($hold, $_);';
X next;
X }
X
X if (/^b$/) {
X $_ = 'next LINE;';
X next;
X }
X
X if (/^b/) {
X s/^b[ \t]*//;
X $lab = &make_label($_);
X if ($lab eq $toplabel) {
X $_ = 'redo LINE;';
X } else {
X $_ = "goto $lab;";
X }
X next;
X }
X
X if (/^t$/) {
X $_ = 'next LINE if $tflag;';
X $tseen++;
X next;
X }
X
X if (/^t/) {
X s/^t[ \t]*//;
X $lab = &make_label($_);
X $_ = q/if ($tflag) {$tflag = ''; /;
X if ($lab eq $toplabel) {
X $_ .= 'redo LINE;}';
X } else {
X $_ .= "goto $lab;}";
X }
X $tseen++;
X next;
X }
X
X if (/^=/) {
X $_ = 'print "$.\n";';
X next;
X }
X
X if (/^q/) {
X chop($_ = <<'EOT');
Xclose(ARGV);
X@ARGV = ();
Xnext LINE;
XEOT
X next;
X }
X } continue {
X if ($space) {
X s/^/$space/;
X s/(\n)(.)/$1$space$2/g;
X }
X last;
X }
X $_;
X}
X
Xsub fetchpat {
X local($outer) = @_;
X local($addr) = $outer;
X local($inbracket);
X local($prefix,$delim,$ch);
X
X # Process pattern one potential delimiter at a time.
X
X DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
X $prefix = $1;
X $delim = $2;
X if ($delim eq '\\') {
X s/(.)//;
X $ch = $1;
X $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
X $ch = 'b' if $ch =~ /^[<>]$/;
X $delim .= $ch;
X }
X elsif ($delim eq '[') {
X $inbracket = 1;
X s/^\^// && ($delim .= '^');
X s/^]// && ($delim .= ']');
X }
X elsif ($delim eq ']') {
X $inbracket = 0;
X }
X elsif ($inbracket || $delim ne $outer) {
X $delim = '\\' . $delim;
X }
X $addr .= $prefix;
X $addr .= $delim;
X if ($delim eq $outer && !$inbracket) {
X last DELIM;
X }
X }
X $addr;
X}
!STUFFY!FUNK!
echo Extracting doio.c:AB
sed >doio.c:AB <<'!STUFFY!FUNK!' -e 's/X//'
X }
X else {
X while (items--) {
X if (kill((int)(str_gnum(st[++sp])),val))
X tot--;
X }
X }
X }
X break;
X#endif
X case O_UNLINK:
X#ifdef TAINT
X taintproper("Insecure dependency in unlink");
X#endif
X tot = items;
X while (items--) {
X s = str_get(st[++sp]);
X if (euid || unsafe) {
X if (UNLINK(s))
X tot--;
X }
X else { /* don't let root wipe out directories without -U */
X#ifdef HAS_LSTAT
X if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
X#else
X if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
X#endif
X tot--;
X else {
X if (UNLINK(s))
X tot--;
X }
X }
X }
X break;
X case O_UTIME:
X#ifdef TAINT
X taintproper("Insecure dependency in utime");
X#endif
X if (items > 2) {
X#ifdef I_UTIME
X struct utimbuf utbuf;
X#else
X struct {
X long actime;
X long modtime;
X } utbuf;
X#endif
X
X Zero(&utbuf, sizeof utbuf, char);
X utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */
X utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */
X items -= 2;
X#ifndef lint
X tot = items;
X while (items--) {
X if (utime(str_get(st[++sp]),&utbuf))
X tot--;
X }
X#endif
X }
X else
X items = 0;
X break;
X }
X return tot;
X}
X
X/* Do the permissions allow some operation? Assumes statcache already set. */
X
Xint
Xcando(bit, effective, statbufp)
Xint bit;
Xint effective;
Xregister struct stat *statbufp;
X{
X#ifdef MSDOS
X /* [Comments and code from Len Reed]
X * MS-DOS "user" is similar to UNIX's "superuser," but can't write
X * to write-protected files. The execute permission bit is set
X * by the Miscrosoft C library stat() function for the following:
X * .exe files
X * .com files
X * .bat files
X * directories
X * All files and directories are readable.
X * Directories and special files, e.g. "CON", cannot be
X * write-protected.
X * [Comment by Tom Dinger -- a directory can have the write-protect
X * bit set in the file system, but DOS permits changes to
X * the directory anyway. In addition, all bets are off
X * here for networked software, such as Novell and
X * Sun's PC-NFS.]
X */
X
X return (bit & statbufp->st_mode) ? TRUE : FALSE;
X
X#else /* ! MSDOS */
X if ((effective ? euid : uid) == 0) { /* root is special */
X if (bit == S_IXUSR) {
X if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
X return TRUE;
X }
X else
X return TRUE; /* root reads and writes anything */
X return FALSE;
X }
X if (statbufp->st_uid == (effective ? euid : uid) ) {
X if (statbufp->st_mode & bit)
X return TRUE; /* ok as "user" */
X }
X else if (ingroup((int)statbufp->st_gid,effective)) {
X if (statbufp->st_mode & bit >> 3)
X return TRUE; /* ok as "group" */
X }
X else if (statbufp->st_mode & bit >> 6)
X return TRUE; /* ok as "other" */
X return FALSE;
X#endif /* ! MSDOS */
X}
X
Xint
Xingroup(testgid,effective)
Xint testgid;
Xint effective;
X{
X if (testgid == (effective ? egid : gid))
X return TRUE;
X#ifdef HAS_GETGROUPS
X#ifndef NGROUPS
X#define NGROUPS 32
X#endif
X {
X GROUPSTYPE gary[NGROUPS];
X int anum;
X
X anum = getgroups(NGROUPS,gary);
X while (--anum >= 0)
X if (gary[anum] == testgid)
X return TRUE;
X }
X#endif
X return FALSE;
X}
X
X#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
X
Xint
Xdo_ipcget(optype, arglast)
Xint optype;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X key_t key;
X int n, flags;
X
X key = (key_t)str_gnum(st[++sp]);
X n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
X flags = (int)str_gnum(st[++sp]);
X errno = 0;
X switch (optype)
X {
X#ifdef HAS_MSG
X case O_MSGGET:
X return msgget(key, flags);
X#endif
X#ifdef HAS_SEM
X case O_SEMGET:
X return semget(key, n, flags);
X#endif
X#ifdef HAS_SHM
X case O_SHMGET:
X return shmget(key, n, flags);
X#endif
X#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
X default:
X fatal("%s not implemented", opname[optype]);
X#endif
X }
X return -1; /* should never happen */
X}
X
Xint
Xdo_ipcctl(optype, arglast)
Xint optype;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X STR *astr;
X char *a;
X int id, n, cmd, infosize, getinfo, ret;
X
X id = (int)str_gnum(st[++sp]);
X n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
X cmd = (int)str_gnum(st[++sp]);
X astr = st[++sp];
X
X infosize = 0;
X getinfo = (cmd == IPC_STAT);
X
X switch (optype)
X {
X#ifdef HAS_MSG
X case O_MSGCTL:
X if (cmd == IPC_STAT || cmd == IPC_SET)
X infosize = sizeof(struct msqid_ds);
X break;
X#endif
X#ifdef HAS_SHM
X case O_SHMCTL:
X if (cmd == IPC_STAT || cmd == IPC_SET)
X infosize = sizeof(struct shmid_ds);
X break;
X#endif
X#ifdef HAS_SEM
X case O_SEMCTL:
X if (cmd == IPC_STAT || cmd == IPC_SET)
X infosize = sizeof(struct semid_ds);
X else if (cmd == GETALL || cmd == SETALL)
X {
X struct semid_ds semds;
X if (semctl(id, 0, IPC_STAT, &semds) == -1)
X return -1;
X getinfo = (cmd == GETALL);
X#ifdef _POSIX_SOURCE
X infosize = semds.sem_nsems * sizeof(ushort_t);
X#else
X infosize = semds.sem_nsems * sizeof(ushort);
X#endif
X }
X break;
X#endif
X#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
X default:
X fatal("%s not implemented", opname[optype]);
X#endif
X }
X
X if (infosize)
X {
X if (getinfo)
X {
X STR_GROW(astr, infosize+1);
X a = str_get(astr);
X }
X else
X {
X a = str_get(astr);
X if (astr->str_cur != infosize)
X {
X errno = EINVAL;
X return -1;
X }
X }
X }
X else
X {
X int i = (int)str_gnum(astr);
X a = (char *)i; /* ouch */
X }
X errno = 0;
X switch (optype)
X {
X#ifdef HAS_MSG
X case O_MSGCTL:
X ret = msgctl(id, cmd, a);
X break;
X#endif
X#ifdef HAS_SEM
X case O_SEMCTL:
X ret = semctl(id, n, cmd, a);
X break;
X#endif
X#ifdef HAS_SHM
X case O_SHMCTL:
X ret = shmctl(id, cmd, a);
X break;
X#endif
X }
X if (getinfo && ret >= 0) {
X astr->str_cur = infosize;
X astr->str_ptr[infosize] = '\0';
X }
X return ret;
X}
X
Xint
Xdo_msgsnd(arglast)
Xint *arglast;
X{
X#ifdef HAS_MSG
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X STR *mstr;
X char *mbuf;
X int id, msize, flags;
X
X id = (int)str_gnum(st[++sp]);
X mstr = st[++sp];
X flags = (int)str_gnum(st[++sp]);
X mbuf = str_get(mstr);
X if ((msize = mstr->str_cur - sizeof(long)) < 0) {
X errno = EINVAL;
X return -1;
X }
X errno = 0;
X return msgsnd(id, mbuf, msize, flags);
X#else
X fatal("msgsnd not implemented");
X#endif
X}
X
Xint
Xdo_msgrcv(arglast)
Xint *arglast;
X{
X#ifdef HAS_MSG
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X STR *mstr;
X char *mbuf;
X long mtype;
X int id, msize, flags, ret;
X
X id = (int)str_gnum(st[++sp]);
X mstr = st[++sp];
X msize = (int)str_gnum(st[++sp]);
X mtype = (long)str_gnum(st[++sp]);
X flags = (int)str_gnum(st[++sp]);
X mbuf = str_get(mstr);
X if (mstr->str_cur < sizeof(long)+msize+1) {
X STR_GROW(mstr, sizeof(long)+msize+1);
X mbuf = str_get(mstr);
X }
X errno = 0;
X ret = msgrcv(id, mbuf, msize, mtype, flags);
X if (ret >= 0) {
X mstr->str_cur = sizeof(long)+ret;
X mstr->str_ptr[sizeof(long)+ret] = '\0';
X }
X return ret;
X#else
X fatal("msgrcv not implemented");
X#endif
X}
X
Xint
Xdo_semop(arglast)
Xint *arglast;
X{
X#ifdef HAS_SEM
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X STR *opstr;
X char *opbuf;
X int id, opsize;
X
X id = (int)str_gnum(st[++sp]);
X opstr = st[++sp];
X opbuf = str_get(opstr);
X opsize = opstr->str_cur;
X if (opsize < sizeof(struct sembuf)
X || (opsize % sizeof(struct sembuf)) != 0) {
X errno = EINVAL;
X return -1;
X }
X errno = 0;
X return semop(id, opbuf, opsize/sizeof(struct sembuf));
X#else
X fatal("semop not implemented");
X#endif
X}
X
Xint
Xdo_shmio(optype, arglast)
Xint optype;
Xint *arglast;
X{
X#ifdef HAS_SHM
X register STR **st = stack->ary_array;
X register int sp = arglast[0];
X STR *mstr;
X char *mbuf, *shm;
X int id, mpos, msize;
X struct shmid_ds shmds;
X extern char *shmat();
X
X id = (int)str_gnum(st[++sp]);
X mstr = st[++sp];
X mpos = (int)str_gnum(st[++sp]);
X msize = (int)str_gnum(st[++sp]);
X errno = 0;
X if (shmctl(id, IPC_STAT, &shmds) == -1)
X return -1;
X if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
X errno = EFAULT; /* can't do as caller requested */
X return -1;
X }
X shm = shmat(id, (char *)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
X if (shm == (char *)-1) /* I hate System V IPC, I really do */
X return -1;
X mbuf = str_get(mstr);
X if (optype == O_SHMREAD) {
X if (mstr->str_cur < msize) {
X STR_GROW(mstr, msize+1);
X mbuf = str_get(mstr);
X }
X bcopy(shm + mpos, mbuf, msize);
X mstr->str_cur = msize;
X mstr->str_ptr[msize] = '\0';
X }
X else {
X int n;
X
X if ((n = mstr->str_cur) > msize)
X n = msize;
X bcopy(mbuf, shm + mpos, n);
X if (n < msize)
X bzero(shm + mpos + n, msize - n);
X }
X return shmdt(shm);
X#else
X fatal("shm I/O not implemented");
X#endif
X}
X
X#endif /* SYSV IPC */
!STUFFY!FUNK!
echo Extracting toke.c:AB
sed >toke.c:AB <<'!STUFFY!FUNK!' -e 's/X//'
X oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr);
X bufend = linestr->str_ptr + linestr->str_cur;
X hereis = FALSE;
X }
X else
X str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */
X }
X else
X s = str_append_till(tmpstr,s+1,bufend,term,leave);
X while (s >= bufend) { /* multiple line string? */
X if (!rsfp ||
X !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
X curcmd->c_line = multi_start;
X fatal("EOF in string");
X }
X curcmd->c_line++;
X if (perldb) {
X STR *str = Str_new(88,0);
X
X str_sset(str,linestr);
X astore(stab_xarray(curcmd->c_filestab),
X (int)curcmd->c_line,str);
X }
X bufend = linestr->str_ptr + linestr->str_cur;
X if (hereis) {
X if (*s == term && bcmp(s,tokenbuf,len) == 0) {
X s = bufend - 1;
X *s = ' ';
X str_scat(linestr,herewas);
X bufend = linestr->str_ptr + linestr->str_cur;
X }
X else {
X s = bufend;
X str_scat(tmpstr,linestr);
X }
X }
X else
X s = str_append_till(tmpstr,s,bufend,term,leave);
X }
X multi_end = curcmd->c_line;
X s++;
X if (tmpstr->str_cur + 5 < tmpstr->str_len) {
X tmpstr->str_len = tmpstr->str_cur + 1;
X Renew(tmpstr->str_ptr, tmpstr->str_len, char);
X }
X if ((arg[1].arg_type & A_MASK) == A_SINGLE) {
X arg[1].arg_ptr.arg_str = tmpstr;
X break;
X }
X tmps = s;
X s = tmpstr->str_ptr;
X send = s + tmpstr->str_cur;
X while (s < send) { /* see if we can make SINGLE */
X if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
X !alwaysdollar && s[1] != '0')
X *s = '$'; /* grandfather \digit in subst */
X if ((*s == '$' || *s == '@') && s+1 < send &&
X (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
X makesingle = FALSE; /* force interpretation */
X }
X else if (*s == '\\' && s+1 < send) {
X if (index("lLuUE",s[1]))
X makesingle = FALSE;
X s++;
X }
X s++;
X }
X s = d = tmpstr->str_ptr; /* assuming shrinkage only */
X while (s < send) {
X if ((*s == '$' && s+1 < send &&
X (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
X (*s == '@' && s+1 < send) ) {
X len = scanident(s,send,tokenbuf) - s;
X if (*s == '$' || strEQ(tokenbuf,"ARGV")
X || strEQ(tokenbuf,"ENV")
X || strEQ(tokenbuf,"SIG")
X || strEQ(tokenbuf,"INC") )
X (void)stabent(tokenbuf,TRUE); /* make sure it exists */
X while (len--)
X *d++ = *s++;
X continue;
X }
X else if (*s == '\\' && s+1 < send) {
X s++;
X switch (*s) {
X default:
X if (!makesingle && (!leave || (*s && index(leave,*s))))
X *d++ = '\\';
X *d++ = *s++;
X continue;
X case '0': case '1': case '2': case '3':
X case '4': case '5': case '6': case '7':
X *d++ = scanoct(s, 3, &len);
X s += len;
X continue;
X case 'x':
X *d++ = scanhex(++s, 2, &len);
X s += len;
X continue;
X case 'c':
X s++;
X *d = *s++;
X if (islower(*d))
X *d = toupper(*d);
X *d++ ^= 64;
X continue;
X case 'b':
X *d++ = '\b';
X break;
X case 'n':
X *d++ = '\n';
X break;
X case 'r':
X *d++ = '\r';
X break;
X case 'f':
X *d++ = '\f';
X break;
X case 't':
X *d++ = '\t';
X break;
X case 'e':
X *d++ = '\033';
X break;
X case 'a':
X *d++ = '\007';
X break;
X }
X s++;
X continue;
X }
X *d++ = *s++;
X }
X *d = '\0';
X
X if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle)
X arg[1].arg_type = A_SINGLE; /* now we can optimize on it */
X
X tmpstr->str_cur = d - tmpstr->str_ptr;
X arg[1].arg_ptr.arg_str = tmpstr;
X s = tmps;
X break;
X }
X }
X if (hereis)
X str_free(herewas);
X return s;
X}
X
XFCMD *
Xload_format()
X{
X FCMD froot;
X FCMD *flinebeg;
X char *eol;
X register FCMD *fprev = &froot;
X register FCMD *fcmd;
X register char *s;
X register char *t;
X register STR *str;
X bool noblank;
X bool repeater;
X
X Zero(&froot, 1, FCMD);
X s = bufptr;
X while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
X curcmd->c_line++;
X if (in_eval && !rsfp) {
X eol = index(s,'\n');
X if (!eol++)
X eol = bufend;
X }
X else
X eol = bufend = linestr->str_ptr + linestr->str_cur;
X if (perldb) {
X STR *tmpstr = Str_new(89,0);
X
X str_nset(tmpstr, s, eol-s);
X astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
X }
X if (*s == '.') {
X for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
X if (*t == '\n') {
X bufptr = s;
X return froot.f_next;
X }
X }
X if (*s == '#') {
X s = eol;
X continue;
X }
X flinebeg = Nullfcmd;
X noblank = FALSE;
X repeater = FALSE;
X while (s < eol) {
X Newz(804,fcmd,1,FCMD);
X fprev->f_next = fcmd;
X fprev = fcmd;
X for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
X if (*t == '~') {
X noblank = TRUE;
X *t = ' ';
X if (t[1] == '~') {
X repeater = TRUE;
X t[1] = ' ';
X }
X }
X }
X fcmd->f_pre = nsavestr(s, t-s);
X fcmd->f_presize = t-s;
X s = t;
X if (s >= eol) {
X if (noblank)
X fcmd->f_flags |= FC_NOBLANK;
X if (repeater)
X fcmd->f_flags |= FC_REPEAT;
X break;
X }
X if (!flinebeg)
X flinebeg = fcmd; /* start values here */
X if (*s++ == '^')
X fcmd->f_flags |= FC_CHOP; /* for doing text filling */
X switch (*s) {
X case '*':
X fcmd->f_type = F_LINES;
X *s = '\0';
X break;
X case '<':
X fcmd->f_type = F_LEFT;
X while (*s == '<')
X s++;
X break;
X case '>':
X fcmd->f_type = F_RIGHT;
X while (*s == '>')
X s++;
X break;
X case '|':
X fcmd->f_type = F_CENTER;
X while (*s == '|')
X s++;
X break;
X case '#':
X case '.':
X /* Catch the special case @... and handle it as a string
X field. */
X if (*s == '.' && s[1] == '.') {
X goto default_format;
X }
X fcmd->f_type = F_DECIMAL;
X {
X char *p;
X
X /* Read a format in the form @####.####, where either group
X of ### may be empty, or the final .### may be missing. */
X while (*s == '#')
X s++;
X if (*s == '.') {
X s++;
X p = s;
X while (*s == '#')
X s++;
X fcmd->f_decimals = s-p;
X fcmd->f_flags |= FC_DP;
X } else {
X fcmd->f_decimals = 0;
X }
X }
X break;
X default:
X default_format:
X fcmd->f_type = F_LEFT;
X break;
X }
X if (fcmd->f_flags & FC_CHOP && *s == '.') {
X fcmd->f_flags |= FC_MORE;
X while (*s == '.')
X s++;
X }
X fcmd->f_size = s-t;
X }
X if (flinebeg) {
X again:
X if (s >= bufend &&
X (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
X goto badform;
X curcmd->c_line++;
X if (in_eval && !rsfp) {
X eol = index(s,'\n');
X if (!eol++)
X eol = bufend;
X }
X else
X eol = bufend = linestr->str_ptr + linestr->str_cur;
X if (perldb) {
X STR *tmpstr = Str_new(90,0);
X
X str_nset(tmpstr, s, eol-s);
X astore(stab_xarray(curcmd->c_filestab),
X (int)curcmd->c_line,tmpstr);
X }
X if (strnEQ(s,".\n",2)) {
X bufptr = s;
X yyerror("Missing values line");
X return froot.f_next;
X }
X if (*s == '#') {
X s = eol;
X goto again;
X }
X str = flinebeg->f_unparsed = Str_new(91,eol - s);
X str->str_u.str_hash = curstash;
X str_nset(str,"(",1);
X flinebeg->f_line = curcmd->c_line;
X eol[-1] = '\0';
X if (!flinebeg->f_next->f_type || index(s, ',')) {
X eol[-1] = '\n';
X str_ncat(str, s, eol - s - 1);
X str_ncat(str,",$$);",5);
X s = eol;
X }
X else {
X eol[-1] = '\n';
X while (s < eol && isspace(*s))
X s++;
X t = s;
X while (s < eol) {
X switch (*s) {
X case ' ': case '\t': case '\n': case ';':
X str_ncat(str, t, s - t);
X str_ncat(str, "," ,1);
X while (s < eol && (isspace(*s) || *s == ';'))
X s++;
X t = s;
X break;
X case '$':
X str_ncat(str, t, s - t);
X t = s;
X s = scanident(s,eol,tokenbuf);
X str_ncat(str, t, s - t);
X t = s;
X if (s < eol && *s && index("$'\"",*s))
X str_ncat(str, ",", 1);
X break;
X case '"': case '\'':
X str_ncat(str, t, s - t);
X t = s;
X s++;
X while (s < eol && (*s != *t || s[-1] == '\\'))
X s++;
X if (s < eol)
X s++;
X str_ncat(str, t, s - t);
X t = s;
X if (s < eol && *s && index("$'\"",*s))
X str_ncat(str, ",", 1);
X break;
X default:
X yyerror("Please use commas to separate fields");
X }
X }
X str_ncat(str,"$$);",4);
X }
X }
X }
X badform:
X bufptr = str_get(linestr);
X yyerror("Format not terminated");
X return froot.f_next;
X}
X
Xset_csh()
X{
X#ifdef CSH
X if (!cshlen)
X cshlen = strlen(cshname);
X#endif
X}
!STUFFY!FUNK!
echo Extracting form.c
sed >form.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: form.c,v 4.0 91/03/20 01:19:23 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.c,v $
X * Revision 4.0 91/03/20 01:19:23 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X/* Forms stuff */
X
Xvoid
Xform_parseargs(fcmd)
Xregister FCMD *fcmd;
X{
X register int i;
X register ARG *arg;
X register int items;
X STR *str;
X ARG *parselist();
X line_t oldline = curcmd->c_line;
X int oldsave = savestack->ary_fill;
X
X str = fcmd->f_unparsed;
X curcmd->c_line = fcmd->f_line;
X fcmd->f_unparsed = Nullstr;
X (void)savehptr(&curstash);
X curstash = str->str_u.str_hash;
X arg = parselist(str);
X restorelist(oldsave);
X
X items = arg->arg_len - 1; /* ignore $$ on end */
X for (i = 1; i <= items; i++) {
X if (!fcmd || fcmd->f_type == F_NULL)
X fatal("Too many field values");
X dehoist(arg,i);
X fcmd->f_expr = make_op(O_ITEM,1,
X arg[i].arg_ptr.arg_arg,Nullarg,Nullarg);
X if (fcmd->f_flags & FC_CHOP) {
X if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
X fcmd->f_expr[1].arg_type = A_LVAL;
X else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
X fcmd->f_expr[1].arg_type = A_LEXPR;
X else
X fatal("^ field requires scalar lvalue");
X }
X fcmd = fcmd->f_next;
X }
X if (fcmd && fcmd->f_type)
X fatal("Not enough field values");
X curcmd->c_line = oldline;
X Safefree(arg);
X str_free(str);
X}
X
Xint newsize;
X
X#define CHKLEN(allow) \
Xnewsize = (d - orec->o_str) + (allow); \
Xif (newsize >= curlen) { \
X curlen = d - orec->o_str; \
X GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
X d = orec->o_str + curlen; /* in case it moves */ \
X curlen = orec->o_len - 2; \
X}
X
Xformat(orec,fcmd,sp)
Xregister struct outrec *orec;
Xregister FCMD *fcmd;
Xint sp;
X{
X register char *d = orec->o_str;
X register char *s;
X register int curlen = orec->o_len - 2;
X register int size;
X FCMD *nextfcmd;
X FCMD *linebeg = fcmd;
X char tmpchar;
X char *t;
X CMD mycmd;
X STR *str;
X char *chophere;
X
X mycmd.c_type = C_NULL;
X orec->o_lines = 0;
X for (; fcmd; fcmd = nextfcmd) {
X nextfcmd = fcmd->f_next;
X CHKLEN(fcmd->f_presize);
X if (s = fcmd->f_pre) {
X while (*s) {
X if (*s == '\n') {
X while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
X d--;
X if (fcmd->f_flags & FC_NOBLANK) {
X if (d == orec->o_str || d[-1] == '\n') {
X orec->o_lines--; /* don't print blank line */
X linebeg = fcmd->f_next;
X break;
X }
X else if (fcmd->f_flags & FC_REPEAT)
X nextfcmd = linebeg;
X else
X linebeg = fcmd->f_next;
X }
X else
X linebeg = fcmd->f_next;
X }
X *d++ = *s++;
X }
X }
X if (fcmd->f_unparsed)
X form_parseargs(fcmd);
X switch (fcmd->f_type) {
X case F_NULL:
X orec->o_lines++;
X break;
X case F_LEFT:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (*s && index(chopset,(*d++ = *s++)))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && *s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X d -= (s - chophere);
X if (fcmd->f_flags & FC_MORE &&
X *chophere && strNE(chophere,"\n")) {
X while (size < 3) {
X d--;
X size++;
X }
X while (d[-1] == ' ' && size < fcmd->f_size) {
X d--;
X size++;
X }
X *d++ = '.';
X *d++ = '.';
X *d++ = '.';
X size -= 3;
X }
X while (*chophere && index(chopset,*chophere))
X chophere++;
X str_chop(str,chophere);
X }
X if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
X size = 0; /* no spaces before newline */
X while (size) {
X size--;
X *d++ = ' ';
X }
X break;
X case F_RIGHT:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X t = s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (*s && index(chopset,*s++))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && *s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X s = chophere;
X while (*chophere && index(chopset,*chophere))
X chophere++;
X }
X tmpchar = *s;
X *s = '\0';
X while (size) {
X size--;
X *d++ = ' ';
X }
X size = s - t;
X (void)bcopy(t,d,size);
X d += size;
X *s = tmpchar;
X if (fcmd->f_flags & FC_CHOP)
X str_chop(str,chophere);
X break;
X case F_CENTER: {
X int halfsize;
X
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X t = s = str_get(str);
X size = fcmd->f_size;
X CHKLEN(size);
X chophere = Nullch;
X while (size && *s && *s != '\n') {
X if (*s == '\t')
X *s = ' ';
X size--;
X if (*s && index(chopset,*s++))
X chophere = s;
X if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
X *s = ' ';
X }
X if (size)
X chophere = s;
X else if (chophere && chophere < s && *s && index(chopset,*s))
X chophere = s;
X if (fcmd->f_flags & FC_CHOP) {
X if (!chophere)
X chophere = s;
X size += (s - chophere);
X s = chophere;
X while (*chophere && index(chopset,*chophere))
X chophere++;
X }
X tmpchar = *s;
X *s = '\0';
X halfsize = size / 2;
X while (size > halfsize) {
X size--;
X *d++ = ' ';
X }
X size = s - t;
X (void)bcopy(t,d,size);
X d += size;
X *s = tmpchar;
X if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
X size = 0; /* no spaces before newline */
X else
X size = halfsize;
X while (size) {
X size--;
X *d++ = ' ';
X }
X if (fcmd->f_flags & FC_CHOP)
X str_chop(str,chophere);
X break;
X }
X case F_LINES:
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X s = str_get(str);
X size = str_len(str);
X CHKLEN(size+1);
X orec->o_lines += countlines(s,size) - 1;
X (void)bcopy(s,d,size);
X d += size;
X if (size && s[size-1] != '\n') {
X *d++ = '\n';
X orec->o_lines++;
X }
X linebeg = fcmd->f_next;
X break;
X case F_DECIMAL: {
X double value;
X
X (void)eval(fcmd->f_expr,G_SCALAR,sp);
X str = stack->ary_array[sp+1];
X size = fcmd->f_size;
X CHKLEN(size);
X /* If the field is marked with ^ and the value is undefined,
X blank it out. */
X if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) {
X while (size) {
X size--;
X *d++ = ' ';
X }
X break;
X }
X value = str_gnum(str);
X if (fcmd->f_flags & FC_DP) {
X sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
X } else {
X sprintf(d, "%*.0f", size, value);
X }
X d += size;
X break;
X }
X }
X }
X CHKLEN(1);
X *d++ = '\0';
X}
X
Xcountlines(s,size)
Xregister char *s;
Xregister int size;
X{
X register int count = 0;
X
X while (size--) {
X if (*s++ == '\n')
X count++;
X }
X return count;
X}
X
Xdo_write(orec,stio,sp)
Xstruct outrec *orec;
Xregister STIO *stio;
Xint sp;
X{
X FILE *ofp = stio->ofp;
X
X#ifdef DEBUGGING
X if (debug & 256)
X fprintf(stderr,"left=%ld, todo=%ld\n",
X (long)stio->lines_left, (long)orec->o_lines);
X#endif
X if (stio->lines_left < orec->o_lines) {
X if (!stio->top_stab) {
X STAB *topstab;
X
X if (!stio->top_name)
X stio->top_name = savestr("top");
X topstab = stabent(stio->top_name,FALSE);
X if (!topstab || !stab_form(topstab)) {
X stio->lines_left = 100000000;
X goto forget_top;
X }
X stio->top_stab = topstab;
X }
X if (stio->lines_left >= 0 && stio->page > 0)
X (void)putc('\f',ofp);
X stio->lines_left = stio->page_len;
X stio->page++;
X format(&toprec,stab_form(stio->top_stab),sp);
X fputs(toprec.o_str,ofp);
X stio->lines_left -= toprec.o_lines;
X }
X forget_top:
X fputs(orec->o_str,ofp);
X stio->lines_left -= orec->o_lines;
X}
!STUFFY!FUNK!
echo Extracting Makefile.SH
sed >Makefile.SH <<'!STUFFY!FUNK!' -e 's/X//'
Xcase $CONFIG in
X'')
X if test ! -f config.sh; then
X ln ../config.sh . || \
X ln ../../config.sh . || \
X ln ../../../config.sh . || \
X (echo "Can't find config.sh."; exit 1)
X fi 2>/dev/null
X . ./config.sh
X ;;
Xesac
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
X
Xcase "$d_symlink" in
X*define*) sln='ln -s' ;;
X*) sln='ln';;
Xesac
X
Xcase "$d_dosuid" in
X*define*) suidperl='suidperl' ;;
X*) suidperl='';;
Xesac
X
Xecho "Extracting Makefile (with variable substitutions)"
Xcat >Makefile <<!GROK!THIS!
X# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:30:39 $
X#
X# $Log: Makefile.SH,v $
X# Revision 4.0.1.1 91/04/11 17:30:39 lwall
X# patch1: C flags are now settable on a per-file basis
X#
X# Revision 4.0 91/03/20 00:58:54 lwall
X# 4.0 baseline.
X#
X#
X
XCC = $cc
XYACC = $yacc
Xbin = $installbin
Xscriptdir = $scriptdir
Xprivlib = $installprivlib
Xmansrc = $mansrc
Xmanext = $manext
XLDFLAGS = $ldflags
XCLDFLAGS = $ldflags
XSMALL = $small
XLARGE = $large $split
Xmallocsrc = $mallocsrc
Xmallocobj = $mallocobj
XSLN = $sln
X
Xlibs = $libs $cryptlib
X
Xpublic = perl taintperl $suidperl
X
X!GROK!THIS!
X
Xcat >>Makefile <<'!NO!SUBS!'
X
XCFLAGS = `sh cflags.SH $@`
X
Xprivate =
X
Xscripts = h2ph
X
XMAKE = make
X
Xmanpages = perl.man h2ph.man
X
Xutil =
X
Xsh = Makefile.SH makedepend.SH h2ph.SH
X
Xh1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h
Xh2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h
X
Xh = $(h1) $(h2)
X
Xc1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
Xc2 = eval.c form.c hash.c $(mallocsrc) perl.c regcomp.c regexec.c
Xc3 = stab.c str.c toke.c util.c usersub.c
X
Xc = $(c1) $(c2) $(c3)
X
Xobj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
Xobj2 = eval.o form.o hash.o $(mallocobj) perl.o regcomp.o regexec.o
Xobj3 = stab.o str.o toke.o util.o
X
Xobj = $(obj1) $(obj2) $(obj3)
X
Xtobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o
Xtobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o
Xtobj3 = tstab.o tstr.o ttoke.o tutil.o
X
Xtobj = $(tobj1) $(tobj2) $(tobj3)
X
Xlintflags = -hbvxac
X
Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
X
X# grrr
XSHELL = /bin/sh
X
X.c.o:
X $(CC) -c $(CFLAGS) $*.c
X
Xall: $(public) $(private) $(util) uperl.o $(scripts)
X cd x2p; $(MAKE) all
X touch all
X
X# This is the standard version that contains no "taint" checks and is
X# used for all scripts that aren't set-id or running under something set-id.
X# The $& notation is tells Sequent machines that it can do a parallel make,
X# and is harmless otherwise.
X
Xperl: $& perly.o $(obj) usersub.o
X $(CC) $(LARGE) $(CLDFLAGS) $(obj) perly.o usersub.o $(libs) -o perl
X
Xuperl.o: $& perly.o $(obj)
X -ld $(LARGE) $(LDFLAGS) -r $(obj) perly.o $(libs) -o uperl.o
X
Xsaber: perly.c
X # load $(c) perly.c
X
X# This version, if specified in Configure, does ONLY those scripts which need
X# set-id emulation. Suidperl must be setuid root. It contains the "taint"
X# checks as well as the special code to validate that the script in question
X# has been invoked correctly.
X
Xsuidperl: $& tperly.o sperl.o $(tobj) usersub.o
X $(CC) $(LARGE) $(CLDFLAGS) sperl.o $(tobj) tperly.o usersub.o $(libs) \
X -o suidperl
X
X# This version interprets scripts that are already set-id either via a wrapper
X# or through the kernel allowing set-id scripts (bad idea). Taintperl must
X# NOT be setuid to root or anything else. The only difference between it
X# and normal perl is the presence of the "taint" checks.
X
Xtaintperl: $& tperly.o tperl.o $(tobj) usersub.o
X $(CC) $(LARGE) $(CLDFLAGS) tperl.o $(tobj) tperly.o usersub.o $(libs) \
X -o taintperl
X
X# Replicating all this junk is yucky, but I don't see a portable way to fix it.
X
Xtperly.o: perly.c perly.h $(h)
X /bin/rm -f tperly.c
X $(SLN) perly.c tperly.c
X $(CC) -c -DTAINT $(CFLAGS) tperly.c
X /bin/rm -f tperly.c
X
Xtperl.o: perl.c perly.h patchlevel.h perl.h $(h)
X /bin/rm -f tperl.c
X $(SLN) perl.c tperl.c
X $(CC) -c -DTAINT $(CFLAGS) tperl.c
X /bin/rm -f tperl.c
X
Xsperl.o: perl.c perly.h patchlevel.h $(h)
X /bin/rm -f sperl.c
X $(SLN) perl.c sperl.c
X $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) sperl.c
X /bin/rm -f sperl.c
X
Xtarray.o: array.c $(h)
X /bin/rm -f tarray.c
X $(SLN) array.c tarray.c
X $(CC) -c -DTAINT $(CFLAGS) tarray.c
X /bin/rm -f tarray.c
X
Xtcmd.o: cmd.c $(h)
X /bin/rm -f tcmd.c
X $(SLN) cmd.c tcmd.c
X $(CC) -c -DTAINT $(CFLAGS) tcmd.c
X /bin/rm -f tcmd.c
X
Xtcons.o: cons.c $(h) perly.h
X /bin/rm -f tcons.c
X $(SLN) cons.c tcons.c
X $(CC) -c -DTAINT $(CFLAGS) tcons.c
X /bin/rm -f tcons.c
X
Xtconsarg.o: consarg.c $(h)
X /bin/rm -f tconsarg.c
X $(SLN) consarg.c tconsarg.c
X $(CC) -c -DTAINT $(CFLAGS) tconsarg.c
X /bin/rm -f tconsarg.c
X
Xtdoarg.o: doarg.c $(h)
X /bin/rm -f tdoarg.c
X $(SLN) doarg.c tdoarg.c
X $(CC) -c -DTAINT $(CFLAGS) tdoarg.c
X /bin/rm -f tdoarg.c
X
Xtdoio.o: doio.c $(h)
X /bin/rm -f tdoio.c
X $(SLN) doio.c tdoio.c
X $(CC) -c -DTAINT $(CFLAGS) tdoio.c
X /bin/rm -f tdoio.c
X
Xtdolist.o: dolist.c $(h)
X /bin/rm -f tdolist.c
X $(SLN) dolist.c tdolist.c
X $(CC) -c -DTAINT $(CFLAGS) tdolist.c
X /bin/rm -f tdolist.c
X
Xtdump.o: dump.c $(h)
X /bin/rm -f tdump.c
X $(SLN) dump.c tdump.c
X $(CC) -c -DTAINT $(CFLAGS) tdump.c
X /bin/rm -f tdump.c
X
Xteval.o: eval.c $(h)
X /bin/rm -f teval.c
X $(SLN) eval.c teval.c
X $(CC) -c -DTAINT $(CFLAGS) teval.c
X /bin/rm -f teval.c
X
Xtform.o: form.c $(h)
X /bin/rm -f tform.c
X $(SLN) form.c tform.c
X $(CC) -c -DTAINT $(CFLAGS) tform.c
X /bin/rm -f tform.c
X
Xthash.o: hash.c $(h)
X /bin/rm -f thash.c
X $(SLN) hash.c thash.c
X $(CC) -c -DTAINT $(CFLAGS) thash.c
X /bin/rm -f thash.c
X
Xtregcomp.o: regcomp.c $(h)
X /bin/rm -f tregcomp.c
X $(SLN) regcomp.c tregcomp.c
X $(CC) -c -DTAINT $(CFLAGS) tregcomp.c
X /bin/rm -f tregcomp.c
X
Xtregexec.o: regexec.c $(h)
X /bin/rm -f tregexec.c
X $(SLN) regexec.c tregexec.c
X $(CC) -c -DTAINT $(CFLAGS) tregexec.c
X /bin/rm -f tregexec.c
X
Xtstab.o: stab.c $(h)
X /bin/rm -f tstab.c
X $(SLN) stab.c tstab.c
X $(CC) -c -DTAINT $(CFLAGS) tstab.c
X /bin/rm -f tstab.c
X
Xtstr.o: str.c $(h) perly.h
X /bin/rm -f tstr.c
X $(SLN) str.c tstr.c
X $(CC) -c -DTAINT $(CFLAGS) tstr.c
X /bin/rm -f tstr.c
X
Xttoke.o: toke.c $(h) perly.h
X /bin/rm -f ttoke.c
X $(SLN) toke.c ttoke.c
X $(CC) -c -DTAINT $(CFLAGS) ttoke.c
X /bin/rm -f ttoke.c
X
Xtutil.o: util.c $(h)
X /bin/rm -f tutil.c
X $(SLN) util.c tutil.c
X $(CC) -c -DTAINT $(CFLAGS) tutil.c
X /bin/rm -f tutil.c
X
Xperly.h: perly.c
X @ echo Dummy dependency for dumb parallel make
X touch perly.h
X
Xperly.c: perly.y
X @ echo 'Expect either' 29 shift/reduce and 59 reduce/reduce conflicts...
X @ echo ' or' 27 shift/reduce and 61 reduce/reduce conflicts...
X $(YACC) -d perly.y
X sh perly.fixer y.tab.c perly.c
X mv y.tab.h perly.h
X echo 'extern YYSTYPE yylval;' >>perly.h
X
Xperly.o: perly.c perly.h $(h)
X $(CC) -c $(CFLAGS) perly.c
X
Xinstall: all
X ./perl installperl
X cd x2p; $(MAKE) install
X
Xclean:
X rm -f *.o all perl taintperl suidperl
X cd x2p; $(MAKE) clean
X
Xrealclean: clean
X cd x2p; $(MAKE) realclean
X rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
X rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
X rm -f x2p/Makefile
X
X# The following lint has practically everything turned on. Unfortunately,
X# you have to wade through a lot of mumbo jumbo that can't be suppressed.
X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
X# for that spot.
X
Xlint: perly.c $(c)
X lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
X
Xdepend: makedepend
X - test -f perly.h || cp /dev/null perly.h
X ./makedepend
X - test -s perly.h || /bin/rm -f perly.h
X cd x2p; $(MAKE) depend
X
Xtest: perl
X - cd t && chmod +x TEST */*.t
X - cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST </dev/tty
X
Xclist:
X echo $(c) | tr ' ' '\012' >.clist
X
Xhlist:
X echo $(h) | tr ' ' '\012' >.hlist
X
Xshlist:
X echo $(sh) | tr ' ' '\012' >.shlist
X
X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
X$(obj):
X @ echo "You haven't done a "'"make depend" yet!'; exit 1
Xmakedepend: makedepend.SH
X /bin/sh makedepend.SH
X!NO!SUBS!
X$eunicefix Makefile
Xcase `pwd` in
X*SH)
X $rm -f ../Makefile
X ln Makefile ../Makefile
X ;;
Xesac
!STUFFY!FUNK!
echo Extracting lib/cacheout.pl
sed >lib/cacheout.pl <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# Open in their package.
X
Xsub cacheout'open {
X open($_[0], $_[1]);
X}
X
X# But only this sub name is visible to them.
X
Xsub cacheout {
X package cacheout;
X
X ($file) = @_;
X ($package) = caller;
X if (!$isopen{$file}) {
X if (++$numopen > $maxopen) {
X sub byseq {$isopen{$a} != $isopen{$b};}
X local(@lru) = sort byseq keys(%isopen);
X splice(@lru, $maxopen / 3);
X $numopen -= @lru;
X for (@lru) { close $_; delete $isopen{$_}; }
X }
X &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
X || die "Can't create $file: $!\n";
X }
X $isopen{$file} = ++$seq;
X}
X
Xpackage cacheout;
X
X$seq = 0;
X$numopen = 0;
X
Xif (open(PARAM,'/usr/include/sys/param.h')) {
X local($.);
X while (<PARAM>) {
X $maxopen = $1 - 4 if /^#define NOFILE\s+(\d+)/;
X }
X close PARAM;
X}
X$maxopen = 16 unless $maxopen;
X
X1;
!STUFFY!FUNK!
echo " "
echo "End of kit 28 (of 36)"
cat /dev/null >kit28isdone
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.