Category : Pascal Source Code
Archive   : TPTOOL19.ZIP
Filename : TOOLU.PAS
Version ='1.9.e';
{ x.x.y Revisors: Please only renumber y, let McGee renumber x.x }
{ ---------- CONFIGURATION to user's system and preferences ------------- }
{ hardware and OS configuration }
SystemDrive ='A:'; { SHELL and all .CHN files will be on this disk }
ShellName ='SHELL.COM'; { .CMD on CP/M-86, .COM on CP/M-80 and MS-DOS }
PipePrefix ='$PIPE'; { prefix with memory disk if available }
TempEditFile='$EDTEMP'; { same }
{ (need to move STEMP and ARTEMP here also) }
TabSpaces = 8; { 4 in K&P, but 8 better for most terminals }
{ To configure, also check inclusion of proper OS file in CHAPTER1.PAS }
{ example configurations:
1. AppleII with CP/M card and two floppy disks
2. DEC Rainbow running CP/M-86, autobooting to
Winchester E:, with large memory drive M:
3. DEC Rainbow running MS-DOS on two floppies,
system on B:, memory drive on E:
AppleII Rainbow Rainbow
CP/M-80 CP/M-86 MS-DOS
---------- ---------- ----------
SystemDrive 'A:' 'E:' 'B:'
ShellName 'SHELL.COM' 'SHELL.CMD' 'SHELL.COM
PipePrefix '$PIPE' 'M:$PIPE' 'E:$PIPE'
TempEditFile '$EDTEMP' 'M:$EDTEMP' 'E:$EDTEMP'
}
{ user preference configurations }
ShellPrompt ='$ ';
EditPrompt =TRUE; { not in K&P; very hard to use edit without it }
Debug = FALSE ; { prints more info; can be handy while learning }
ListProcess = TRUE; { echo second and subsequent processes }
Abbreviate = false; { can shorten commands -- uses first match }
AppendFNamePAS = FALSE; { converts, i.e. filename "TEXT" to "TEXT.PAS" }
{ K&P had AppendFNamePAS=TRUE, but it's confusing for non-program files }
{ --------------------- end of CONFIGURATION section --------------------- }
MAXCMD=20; { max arguments to one process }
ENDFILE=255;
ENDSTR=0;
MAXSTR=130;
{ ASCII character set in decimal }
BLANK=32;
BACKSPACE=8; { backs up cursor one space; may be different from DELETE! }
DELETE1 = 127; { user types this to delete prior character entered }
DELETE2 = 8; { user can also delete with this (=DELETE1 to remove) }
TAB=9;
NEWLINE=13; { internal eol flag; also, terminates console input line }
EXCLAM=33;
DQUOTE=34;
SHARP=35;
DOLLAR=36;
PERCENT=37;
AMPER=38;
SQUOTE=39;
ACUTE=SQUOTE;
LPAREN=40;
RPAREN=41;
STAR=42;
PLUS=43;
COMMA=44;
MINUS=45;
DASH=MINUS;
PERIOD=46;
SLASH=47;
COLON=58;
SEMICOL=59;
LESS=60;
EQUALS=61;
GREATER=62;
QUESTION=63;
ATSIGN=64;
ESCAPE=ATSIGN;
LBRACK=91;
BACKSLASH=92;
RBRACK=93;
CARET=94;
GRAVE=96;
UNDERLINE=95;
TILDE=126;
LBRACE=123;
BAR=124;
RBRACE=125;
TYPE
CHARACTER=0..255;
XSTRING=ARRAY[1..MAXSTR]OF CHARACTER;
STRING80=string[80];
FILEDESC=(IOERROR,STDIN,STDOUT,STDERR,F4,F5,F6,F7,F8,F9,F10,MAXOPEN);
(* add as many Fn numbers as you need files; > F7 needed only by sort *)
FileModes = (IOREAD,IOWRITE);
FILTYP=(CLOSED,STDIO,OpenFile);
VAR
{ The process and pipe vars MUST be the first declared in every program }
{ chained to. Thus, do not declare any variables before $I TOOLU.PAS. }
ActiveProcessQ, FromPipe, ToPipe : boolean;
PipeCount : integer;
ProcessQueue : XSTRING;
KBDN,KBDNEXT:INTEGER;
KBDLINE,CMDLIN:XSTRING;
CMDARGS:0..MAXCMD;
CMDIDX:ARRAY[1..MAXCMD] OF 1..MAXSTR;
GlobalArg1: STRING80;
CMDFIL:ARRAY[STDIN..MAXOPEN]OF FILTYP;
CMDText: ARRAY[STDIN..MAXOPEN] OF TEXT;
ReadingShellCmd : boolean;
PROCEDURE PUTDEC(N,W:INTEGER);FORWARD;
FUNCTION ITOC(N:INTEGER;VAR S:XSTRING;I:INTEGER):INTEGER;FORWARD;
FUNCTION GETARG(N:INTEGER;VAR S:XSTRING; MAXSIZE:INTEGER):BOOLEAN;FORWARD;
PROCEDURE SCOPY(VAR SRC:XSTRING;I:INTEGER;VAR DEST:XSTRING;J:INTEGER);FORWARD;
PROCEDURE ENDCMD;FORWARD;
PROCEDURE XCLOSE(FD:FILEDESC);FORWARD;
FUNCTION XLENGTH(VAR S:XSTRING):INTEGER;FORWARD;
PROCEDURE ERROR(STR:STRING80);FORWARD;
FUNCTION MAX(X,Y:INTEGER):INTEGER;FORWARD;
PROCEDURE REMOVE(NAME:XSTRING);FORWARD;
FUNCTION NARGS:INTEGER;FORWARD;
FUNCTION ADDSTR(C:CHARACTER;VAR OUTSET:XSTRING;VAR J:INTEGER;MAXSET:INTEGER):
BOOLEAN;FORWARD;
PROCEDURE PUTSTR(STR:XSTRING;FD:FILEDESC);FORWARD;
FUNCTION MIN(X,Y:INTEGER):INTEGER;FORWARD;
FUNCTION ISUPPER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION EQUAL(VAR STR1,STR2:XSTRING):BOOLEAN;FORWARD;
FUNCTION INDEX(VAR S:XSTRING;C:CHARACTER):INTEGER;FORWARD;
FUNCTION ISALPHANUM(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ESC(VAR S:XSTRING;VAR I:INTEGER): CHARACTER;FORWARD;
PROCEDURE FCOPY(FIN,FOUT:FILEDESC);FORWARD;
FUNCTION CTOI(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
FUNCTION ISDIGIT(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLOWER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLETTER(C:CHARACTER):BOOLEAN;FORWARD;
{ system support }
PROCEDURE GenPipeName(PipeNumber: integer; var name: XSTRING);
{ Generate a pipe file name }
var str: STRING80;
len, i: integer;
begin
str := PipePrefix; len := LENGTH(STR);
for i := 1 to len do name[i] := ORD(str[i]);
name[len+1] := ENDSTR;
i := ITOC(PipeNumber,name,(len+1)); { append digits }
end;
procedure AssignPipe0(var f: text);
var s: STRING80; name: XSTRING; i:integer;
begin
GenPipeName(0,name);
s := ''; i := 1;
while name[i] <> ENDSTR do begin
s := s + chr(name[i]); i:= i+1;
end;
{close(f);} { causes crash on CP/M-86 }
assign(f,s);
end;
function EntryFromHost: boolean;
{ The routines EntryFromHost and SetEntryFromHost implement a boolean
variable which is always TRUE when SHELL is first invoked, and which
remains FALSE across subsequent invocations via Chain/Execute }
{ Implemented via a file name, which is portable across all Turbo systems }
var pipe0: text;
begin
AssignPipe0(pipe0);
{$I- } reset(pipe0);; {$I+ }
EntryFromHost := (IOResult<>0); { false if file exists }
close(pipe0);
{ CP/M-80 allows minor speedup at cost of portability: }
{ replace all code in this procedure by: EntryFromHost:= (mem[$80]<>255) }
{ and comment-out all code in SetEntryFromHost }
end;
procedure SetEntryFromHost(entry: boolean);
var pipe0: text;
begin
AssignPipe0(pipe0);
rewrite(pipe0); close(pipe0); { access or create (empty) file }
if entry then erase(pipe0); { remove file }
end;
procedure ExitToHost;
{ Exit program by calling this. DO NOT CALL HALT DIRECTLY! }
BEGIN
SetEntryFromHost(TRUE);
HALT;
END;
procedure ExitToShell;
VAR cmdptr: file;
BEGIN
assign(cmdptr,SystemDrive+ShellName);
execute(cmdptr)
END;
procedure RemovePipe(OldPipe: integer);
var name: XSTRING;
begin
GenPipeName(OldPipe,name);
REMOVE(name);
end;
FUNCTION ISDIGIT;
BEGIN
ISDIGIT:=C IN [ORD('0')..ORD('9')]
END;
FUNCTION ISLOWER;
BEGIN
ISLOWER:=C IN [ORD('a')..ORD('z')]
END;
FUNCTION ISLETTER;
BEGIN
ISLETTER:=C IN [ORD('A')..ORD('Z'),ORD('a')..ORD('z')]
END;
FUNCTION CTOI;
VAR N,SIGN:INTEGER;
BEGIN
WHILE (S[I]=BLANK) OR (S[I]=TAB)DO
I:=I+1;
IF(S[I]=MINUS) THEN
SIGN:=-1
ELSE
SIGN:=1;
IF(S[I]=PLUS)OR(S[I]=MINUS)THEN
I:=I+1;
N:=0;
WHILE(ISDIGIT(S[I])) DO BEGIN
N:=10*N+S[I]-ORD('0');
I:=I+1
END;
CTOI:=SIGN*N
END;
FUNCTION GETKBD(VAR C:CHARACTER):CHARACTER;
VAR DONE:BOOLEAN;
i:integer;
ch:char;
BEGIN
IF (KBDN<=0) THEN BEGIN
KBDNEXT:=1;
DONE:=FALSE;
if (kbdn=-2) then begin kbdn:=0 end
else if (kbdn<0)then done:=true;
WHILE(NOT DONE) DO BEGIN
kbdn:=kbdn+1;
DONE:=TRUE;
if (eof(TRM)) then kbdn:=-1
else if eoln(TRM) then begin
kbdn:=kbdn-1;kbdline[kbdn]:=NEWLINE
end
else if (MAXSTR-1<=kbdn) then begin
if ReadingShellCmd then
ERROR(' Line too long - ignored')
else begin
writeln(' Line too long - truncated');
kbdline[kbdn]:=newline
end
END
ELSE begin
read(TRM,ch);kbdline[kbdn]:=ord(ch);
if (ord(ch)in ([0..31]-[DELETE1,DELETE2,NEWLINE])) then
write('^',chr(ord(ch)+64)) else
if (kbdline[kbdn]<>DELETE1) and (kbdline[kbdn]<>DELETE2) then
ELSE begin
write(chr(BACKSPACE),' ',chr(BACKSPACE));
if (1
if kbdline[kbdn+1]in[0..31] then
write(chr(BACKSPACE),' ',chr(BACKSPACE))
end
ELSE kbdn:=kbdn-1
end;
done:=false
end;
END
END;
reset(TRM);
IF(KBDN<=0)THEN
C:=ENDFILE
ELSE BEGIN
C:=KBDLINE[KBDNEXT];
KBDNEXT:=KBDNEXT+1;
if (c=NEWLINE) then kbdn:=-2
ELSE KBDN:=KBDN-1
END;
GETKBD:=C
END;
FUNCTION FGETCF(VAR FIL:TEXT):CHARACTER;
VAR CH:CHAR;
BEGIN
{ -disabled - $ I- do not hang on I/O error }
IF(EOF(FIL))THEN
FGETCF:=ENDFILE
ELSE IF(EOLN(FIL)) THEN BEGIN
READLN(FIL);
FGETCF:=NEWLINE
END
ELSE BEGIN
READ(FIL,CH);
FGETCF:=ORD(CH);
END;
if (IOresult <> 0) then
ERROR('FGETCF: I/O error');
{$I+ }
END;
FUNCTION GETCF(VAR C:CHARACTER;FD:FILEDESC):CHARACTER;
BEGIN
IF CMDFIL[FD] = STDIO
THEN GETCF := GETKBD(C)
ELSE BEGIN C := FGETCF(CMDText[FD]); GETCF := C; END;
END;
FUNCTION GETC(VAR C:CHARACTER):CHARACTER;
BEGIN
GETC:=GETCF(C,STDIN)
END;
PROCEDURE PUTCF(C:CHARACTER;FD:FILEDESC);
BEGIN
(* assert CMDFIL[FD] <> STDIO *)
if C=NEWLINE
THEN WRITELN(CMDText[FD])
ELSE WRITE(CMDText[FD],chr(C));
END;
PROCEDURE PUTC(C:CHARACTER);
BEGIN
(* PUTCF(C,STDOUT); *)
if C=NEWLINE
then writeln(CMDText[STDOUT])
else write(CMDText[STDOUT],chr(C));
END;
PROCEDURE FCOPY;
VAR
C:CHARACTER;
BEGIN
WHILE(GETCF(C,FIN)<>ENDFILE) DO
PUTCF(C,FOUT)
END;
FUNCTION INDEX;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(S[I]<>C) AND (S[I]<>ENDSTR)DO
I:=I+1;
IF (S[I]=ENDSTR) THEN
INDEX:=0
ELSE
INDEX:=I
END;
FUNCTION ESC;
BEGIN
IF(S[I]<>ATSIGN) THEN
ESC:=S[I]
ELSE IF(S[I+1]=ENDSTR) THEN (*@ NOT SPECIAL AT END*)
ESC:=ATSIGN
ELSE BEGIN
I:=I+1;
IF(S[I]=ORD('n'))THEN ESC:=NEWLINE
ELSE IF (S[I]=ORD('t')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
FUNCTION ISALPHANUM;
BEGIN
ISALPHANUM:=C IN
[ORD('A')..ORD('Z'),ORD('0')..ORD('9'),
ORD('a')..ORD('z')]
END;
FUNCTION MAX;
BEGIN
IF(X>Y)THEN
MAX:=X
ELSE
MAX:=Y
END;
FUNCTION MIN;
BEGIN
IF X
ELSE
MIN:=Y
END;
FUNCTION ISUPPER;
BEGIN
ISUPPER:=C IN [ORD('A')..ORD('Z')]
END;
FUNCTION XLENGTH;
VAR
N:INTEGER;
BEGIN
N:=1;
WHILE(S[N]<>ENDSTR)DO
N:=N+1;
XLENGTH:=N-1
END;
FUNCTION GETARG;
BEGIN
IF((N<1)OR(CMDARGS
ELSE BEGIN
SCOPY(CMDLIN,CMDIDX[N],S,1);
GETARG:=TRUE
END
END;(*GETARG*)
PROCEDURE SCOPY;
BEGIN
SRC[MAXSTR]:=ENDSTR; { safety }
WHILE(SRC[I]<>ENDSTR)DO BEGIN
DEST[J]:=SRC[I];
I:=I+1;
J:=J+1
END;
DEST[J]:=ENDSTR
END;
PROCEDURE STRNAME(VAR STR:STRING80;VAR XSTR:XSTRING);
VAR I:INTEGER;
BEGIN
IF AppendFNamePAS
THEN STR:='.PAS' else STR := '' ;
I:=1;
WHILE(XSTR[I]<>ENDSTR)DO BEGIN
INSERT('X',STR,I);
STR[I]:=CHR(XSTR[I]);
I:=I+1
END
END;
PROCEDURE NAMESTR(VAR XSTR:XSTRING; STR:STRING80);
VAR I: INTEGER;
BEGIN
FOR I:= 1 TO length(STR) DO XSTR[I]:=ord(STR[I]);
XSTR[1+length(STR)] := ENDSTR;
END;
FUNCTION FDALLOC:FILEDESC;
VAR DONE:BOOLEAN;
FD:FILEDESC;
BEGIN
IF Debug THEN begin write('entry to FDALLOC: ');
for FD := STDIN TO MAXOPEN DO case CMDFIL[FD] OF
CLOSED: WRITE(' c'); STDIO:WRITE(' s'); OpenFile:write(' o'); end;
writeln;
end;
FD:=STDIN;
DONE:=FALSE;
WHILE(NOT DONE) DO
IF((CMDFIL[FD]=CLOSED) OR (FD=MAXOPEN))THEN
DONE:=TRUE
ELSE FD:=SUCC(FD);
IF(CMDFIL[FD]<>CLOSED) THEN
FDALLOC:=IOERROR
ELSE BEGIN
CMDFIL[FD]:= OpenFile;
FDALLOC:=FD
END
END;(*FDALLOC*)
FUNCTION CREATE(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR
FD:FILEDESC;
SNM:STRING80;
BEGIN
(*$I-*)
FD:=FDALLOC;
IF(FD<>IOERROR)THEN BEGIN
STRNAME(SNM,NAME);
ASSIGN(CMDText[FD],SNM); REWRITE(CMDText[FD]);
IF(IORESULT<>0)THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
END;
CREATE:=FD;
END;
(*$I+*)
PROCEDURE ERROR;
BEGIN
WRITELN(STR);
ActiveProcessQ := FALSE;
if ToPipe then RemovePipe(PipeCount);
ENDCMD;
END;
FUNCTION MUSTCREATE(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR
FD:FILEDESC;
BEGIN
FD:=CREATE(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
ERROR(': can''t create file')
END;
MUSTCREATE:=FD
END;
FUNCTION NARGS;
BEGIN
NARGS:=CMDARGS
END;
FUNCTION OPEN(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR FD:FILEDESC;
SNM:STRING80;
BEGIN
FD:=FDALLOC;
IF(FD<>IOERROR) THEN BEGIN
STRNAME(SNM,NAME);
ASSIGN(CMDText[FD],SNM);
(*$I-*)
IF TRUE (* MODE=IOREAD *)
THEN RESET(CMDText[FD])
ELSE REWRITE(CMDText[FD]);
IF(IORESULT<>0) THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
(*$I+*)
END;
OPEN:=FD
END;
PROCEDURE REMOVE;
VAR
FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,IOREAD);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
WRITELN(': can''t remove file');
END
ELSE BEGIN
IF Debug THEN BEGIN PUTSTR(NAME,STDERR); WRITELN(' being removed'); END;
(* assert CMDFILE[FD]=OpenFile *)
CLOSE(CMDText[FD]); ERASE(CMDText[FD]);
END;
CMDFIL[FD]:=CLOSED
END;
FUNCTION GETLINE(VAR STR:XSTRING;FD:FILEDESC; SIZE:INTEGER):BOOLEAN;
VAR I:INTEGER;
DONE:BOOLEAN;
CH:CHARACTER;
BEGIN
I:=0;
REPEAT
DONE:=TRUE;
CH:=GETCF(CH,FD);
IF(CH=ENDFILE) THEN
I:=0
ELSE IF (CH=NEWLINE) THEN BEGIN
I:=I+1;
STR[I]:=NEWLINE
END
ELSE IF (SIZE-2<=I) THEN BEGIN
WRITELN('LINE TOO LONG');
I:=I+1;
STR[I]:=NEWLINE
END
ELSE BEGIN
DONE:=FALSE;
I:=I+1;
STR[I]:=CH
END
UNTIL(DONE);
STR[I+1]:=ENDSTR;
GETLINE:=(0 END;(*GETLINE*)
PROCEDURE ENDCMD;
VAR FD:FILEDESC;
BEGIN
if FromPipe then RemovePipe(PipeCount-ORD(ToPipe));
if not ToPipe then PipeCount := 0;
FOR FD:=STDIN TO MAXOPEN DO XCLOSE(FD);
ExitToShell;
END;
PROCEDURE XCLOSE;
BEGIN
IF CMDFIL[FD] = OpenFile THEN CLOSE(CMDText[FD]);
CMDFIL[FD]:=CLOSED
END;
FUNCTION ADDSTR;
BEGIN
IF(J>MAXSET)THEN
ADDSTR:=FALSE
ELSE BEGIN
OUTSET[J]:=C;
J:=J+1;
ADDSTR:=TRUE
END
END;
PROCEDURE PUTSTR;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(STR[I]<>ENDSTR) DO BEGIN
PUTCF(STR[I],FD);
I:=I+1
END
END;
FUNCTION MUSTOPEN(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
ERROR(': can''t open file.')
END;
MUSTOPEN:=FD
END;
FUNCTION ITOC;
BEGIN
IF(N<0)THEN BEGIN
S[I]:=ORD('-');
ITOC:=ITOC(-N,S,I+1);
END
ELSE BEGIN
IF (N>=10)THEN
I:=ITOC(N DIV 10,S, I);
S[I]:=N MOD 10 + ORD('0');
S[I+1]:=ENDSTR;
ITOC:=I+1;
END
END;
PROCEDURE PUTDEC;
VAR I,ND:INTEGER;
S:XSTRING;
BEGIN
ND:=ITOC(N,S,1);
FOR I:=ND TO W DO
PUTC(BLANK);
FOR I:=1 TO ND-1 DO
PUTC(S[I])
END;
FUNCTION EQUAL;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(STR1[I]=STR2[I])AND(STR1[I]<>ENDSTR) DO
I:=I+1;
EQUAL:=(STR1[I]=STR2[I])
END;
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/