home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
pub
/
queenskermit
/
kermit.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2020-01-01
|
18KB
|
351 lines
{$R-,S-,I-,D+,T-,F-,V-,B-,N-,L+ }
{$M 32768,0,131072 }
Program Kermit ;
(* ***************************************************************** *)
(* *)
(* Author - Victor Lee *)
(* Queen's University , Phone *)
(* Kingston, Ontario, CANADA (613)-545-2033 *)
(* K7L 3N6 *)
(* Comments and problems can be sent to VIC at QUCDN.BITNET *)
(* or to Victor.Lee@Queens.CA *)
(* *)
(* Date - 1985 January *)
(* - 1985 May 1 first official release *)
(* Acknowlegement - *)
(* Victoria Henderson - original Tek4010 coding. *)
(* Contributions from Kevin Lowey, Gisbert W.Selke and *)
(* special thank to many others who have reported bugs, *)
(* provided fixes, and offered suggestions for improvement. *)
(* *)
(* Date - 1988 April Version 3.0 *)
(* Version 3.0 is a major rewrite of QK-Kermit using *)
(* Turbo Pascal 4.0. This version is for MsDos systems *)
(* only and CP/M systems are no longer supported. *)
(* Improved graphic support, Large packet size, *)
(* and script commands for automated logons. *)
(* Modifications *)
(* 1988 May - Ack Data Packets earlier. *)
(* June 29 - Fix bug in using Directory Prefixes in *)
(* Sendfile. *)
(* July 15 - Don't mask out bit8 if parity NONE *)
(* Sept 16 - Tek4100 terminal emulation replaces *)
(* the Tek4010, to enable color graphics. *)
(* Sept 30 - Fix from Andy Rutherford (AGRSI@CUNYVM) *)
(* to handle non-graphics Monochrome monitor. *)
(* Oct 7 - Official Release of 3.1 *)
(* *)
(* ***************************************************************** *)
(* Kermit UNITS *)
(* *)
(* KGLOBALS - Global variables and utility procedures *)
(* GetToken *)
(* UpperCase *)
(* Prefixof *)
(* NewAsFile *)
(* SYSFUNC - These are operating system dependent procedures *)
(* KeyChar *)
(* CursorUp,CursorDown,CursorRight,CursorLeft *)
(* Scroll,FatCursor, *)
(* LocalScreen,RemoteScreen *)
(* SetDefaultDrive,DefaultDrive *)
(* MODEMPRO - These are Machine dependent Modem procedures *)
(* InitModem,ResetModem,SetModem, *)
(* AnswerModem,DialModem *)
(* RecvChar,SendChar,SendBreak, *)
(* CharsInBuffer,EmptyBuffer *)
(* PACKETS - packet related procedures *)
(* ReadChar,ReadMChar *)
(* SendPacket,RecvPacket, *)
(* ReSendit,SendPacketType, *)
(* PutInitPacket,GetInitPacket *)
(* SENDRECV - Sending and Receiving file procedures *)
(* RECVFILE *)
(* SENDFILE *)
(* BreakAck *)
(* VT100 - Terminal Emulation procedure *)
(* CONNECT *)
(* TEK4100 - Graphics terminal emulation procedure *)
(* Tektronics *)
(* SETSHOW - set and show options *)
(* ShowOptions *)
(* SetOptions *)
(* DisplayCommands *)
(* LOCAL - local procedures *)
(* DisplayDir - Display directory. *)
(* EraseFiles - Erase files. *)
(* RenameFiles - Rename files. *)
(* DisplayFile - Display file (TYPE file ). *)
(* (RunFile - Run a program ( See SYSFUNC procedures ) ) *)
(* DEFWORDS - Define Words procedures *)
(* AssignDefWord *)
(* DisplayDefWords *)
(* CheckDefWords *)
(* WriteDefWord *)
(* DEFINEWORD *)
(* LoadDefWords *)
(* SaveDefWords *)
(* REMOTEU - Remote request procedures *)
(* RemotePro *)
(* MISCCOMM - Miscellaneous command *)
(* Logit - log the session to a file. *)
(* Takeit - take commands from a file. *)
(* QuitExit - terminate kermits and log out. *)
(* DRIVERS - graphics drivers from Turbo pascal 4.0 *)
(* FONTS - graphics fonts from Turbo pascal 4.0 *)
(* *)
(* ***************************************************************** *)
uses Dos,Crt,printer,graph, (* Standard Turbo Pascal Units *)
KGlobals, (* Kermit Globals *)
ModemPro,
Vt100,tek4100,
SetShow,SendRecv,RemoteU,
MiscComm,Local,Defwords ;
TYPE
Commandindex = (
zero,
wait,
connect,
send,
receive,
setparm,
status,
directory,
erase,
rename,
typefile,
runfile,
remote,
log,
take,
define,
help,
mkdirl,
rmdirl,
chdirl,
audio,
parms,
line25,
quit,
null );
Commandindex2= (zero2,input,output,pause,echo,clear);
VAR
timeout : boolean ;
inbyte : byte ;
Hour,hh,mm,ss,ms : word ;
i,j,inlength,inputTimer,timer,alarm : integer ;
inputstring, NameString : string ;
command, commandtable,commandtable2,inbuff : string ;
(* ***************************************************************** *)
(* ******** Outter Block of Kermit ****************************** *)
(* ***************************************************************** *)
BEGIN (* KERMIT *)
commandtable := concat('bad ',
'WAIT ',
'CONNECT ',
'SEND ',
'RECEIVE ',
'SET ',
'STATUS ',
'DIRECTORY ',
'ERASE DEL ',
'RENAME ',
'TYPE ',
'RUN EXEC ',
'REMOTE ',
'LOG ',
'TAKE ',
'DEFINE ',
'HELP ? ',
'MKDIR MD ',
'RMDIR RD ',
'CHDIR CD ',
'AUDIO ',
'PARMS ',
'LINE25 ',
'QUIT EXIT ',
'DO LOCAL ') ;
commandtable2 := concat('bad2 ',
'INPUT ',
'OUTPUT ',
'PAUSE ',
'ECHO ',
'CLEAR ') ;
Writeln(' * ======================================== * ');
Writeln(' * Queen''s University - KERMIT /',termtype,' * ');
Writeln(' * * ');
Writeln(' * Version ',version,Gversion,' - ',Date,' * ');
Writeln(' * Author - Victor Lee * ');
Writeln(' * Graphics ',Graphics,' * ');
Writeln(' * ======================================== * ');
inputstring := '' ;
For i := 1 to ParamCount do
inputstring := inputstring + ' ' + paramstr(i) ;
Running := True ;
While Running Do
Begin (* Command Loop *)
if audioflag then
Begin sound(1500);delay(50);sound(300);delay(50);nosound; end ;
if length(inputstring)<1 then
if TakeActive then
Begin (* Get command from file *)
Readln(Commandfile,inputstring);
TakeActive := not Eof(commandfile);
if Eof(commandfile) then close(commandfile);
End
else
Begin (* ask for input *)
Write('QK-Kermit>'); (* PROMPT for input *)
readln(inputstring);
End ; (* ask for input *)
command := Uppercase(GETTOKEN(inputstring));
CheckDefWords(DefList,command,Inputstring);
command := ' ' + command ;
WaitXon := false ;
case commandindex(POS(command,commandtable) div 10 ) of
zero : If length(command)>1 then
Begin (* check table 2 - Script commands *)
case commandindex2(POS(command,commandtable2) div 10) of
zero2 :
Begin (* bad command *)
Writeln('Invalid Command >>>>> ',Command,' <<<<<');
Writeln('--- Type HELP to see valid Commands.--- ');
End ; (* bad command *)
input : Begin (* Input Command *)
Val(GetToken(InputString),InputTimer,j) ;
i := 1 ;
GetTime(hh,mm,ss,ms);
Alarm := mm*60 + ss + InputTimer ;
inlength := length(inputstring);
timeout:=false;
While (i <= inlength) and (not timeout) do
If RecvChar(inbyte) then
Begin (* got char *)
If chr(inbyte) = InputString[i] then
begin (* matches *)
InBuff[i] := chr(inbyte) ;
InBuff[0] := chr(i) ;
i := i + 1 ;
end (* matches *)
else
i := 1 ;
write(chr(inbyte));
End (* got char *)
else
Begin (* time it *)
GetTime(Hour,mm,ss,ms);
Timer := mm*60 + ss ;
If Hour<>hh then Timer := Timer + 3600 ;
If Timer > Alarm then timeout := true ;
End ; (* time it *)
if timeout then writeln('Timed Out')
; (* else writeln(inputstring); *)
inputstring := '';
End ; (* Input Command *)
output : Begin (* Output Command *)
For i := 1 to length(inputstring) do
if inputstring[i]='~' then
Sendchar(CR_) (* carriage return *)
else
Sendchar(ord(inputstring[i]));
InputString := '';
End ; (* Output Command *)
pause : Begin (* pause *)
Val(GetToken(Inputstring),i,j);
delay(i);
End ; (* pause *)
echo : Begin writeln(inputstring); inputstring := ''; end;
clear : Begin (* Clear *)
DialModem ;
For i := 1 to 255 do Inbuff := ' ';
End ; (* Clear *)
end ; (* case *)
End ; (* check table 2 - Script commands *)
wait : Begin AnswerModem ; Connection ; End ;
connect : Begin
If length(inputstring) > 1 then SetOptions(inputstring);
CONNECTION ;
End;
send : SENDFILE (inputstring);
receive : RECVFILE (inputstring );
setparm : SetOptions(inputstring);
status : ShowOptions ;
directory: DisplayDir (inputstring);
erase : EraseFiles (GetToken(inputstring));
rename : RenameFile (inputstring);
typefile : DisplayFile (GetToken(inputstring));
runfile : Begin (* RunFile *)
NameString := GetToken(Inputstring) ;
if Pos('.',NameString) = 0 then
NameString := NameString + '.EXE' ;
EXEC (NameString,inputstring);
Case DosError of
2: Writeln('File ',NameString,' not Found');
5: Writeln('Acess Denied');
8: Writeln('Insufficient Memory to load program');
10: Writeln('Invalid Environment.');
11: Writeln('Unable to Execute file');
end ; (* DosError Case *)
inputstring := '' ;
end ; (* RunFile *)
remote : RemoteProc (inputstring);
log : Logit (GetToken(inputstring));
take : Takeit (GetToken(inputstring));
define : DefineWord(inputstring);
help : DisplayCommands ;
mkdirl : Begin (* Make Directory *)
NameString := GetToken(Inputstring) ;
{$I-} Mkdir (NameString) ; {$I+}
If IoResult = 0 then
writeln('Directory ',NameString,' maked OK.')
else
writeln('Unable to make directory - ',NameString);
End ;(* Make Directory *)
chdirl : Begin (* Change Directory *)
NameString := GetToken(Inputstring) ;
{$I-} Chdir (NameString) ; {$I+}
If IoResult = 0 then
writeln('Directory changed to ',NameString)
else
writeln('Unable to change directory - ',NameString);
End ;(* Change Directory *)
rmdirl : Begin (* Remove Directory *)
NameString := GetToken(Inputstring) ;
{$I-} Rmdir (NameString) ; {$I+}
If IoResult = 0 then
writeln('Directory ',NameString,' removed. ')
else
writeln('Unable to remove directory - ',NameString);
End ;(* Remove Directory *)
audio : AudioFlag := AudioFlag xor True ;
parms : ParmFlag := ParmFlag xor True ;
line25 : Line25Flag := Line25Flag xor True ;
quit : QuitExit (UpperCase(GetToken(inputstring)));
null : ;
end ; (* Case commandindex *)
End ; (* Command Loop *)
If Logging then Close(Logfile);
If NewDefs then SaveDefWords ;
If audioflag then
begin sound(1500);delay(200);sound(3000);delay(200);end ;
ResetModem;
If audioflag then
begin sound(2000);delay(200); nosound; end ;
ClrScr;
Gotoxy(20,10); Write( ' G O O D - B Y E ');
END. (* KERMIT *)