!JOB NAME=KERMIT
!PASCAL ME OVER KERMIT_OBJ (NDB,LS)
{
Program Kermit implements the KERMIT protocol under HONEYWELL/CP6.
Authors: Philip Murton - original RT-11 pascal program.
Bruce W. Pinn - modified version for VAX/VMS.
Douglas Vaughan, Cheryl Poostay, Kevin Asplen, Jay Undercoffler
- modified VAX/VMS version for HONEYWELL/CP6.
Date: March 27, 1985
Site: Bucknell University Computing Services
Lewisburg, Pennsylvania 17837
(717) 524-1801
}
program Kermit(input,output,LINE,ERRORS,DiskOutFile,DiskInFile);
label
9999; { used only to simulate a "halt" instruction }
{%INCLUDE 'CURRENT_GLOBAL'(lines 22-102)}
{label
9999; } { used only to simulate a "halt" instruction }
const
{ other io-related stuff }
IOERROR = 0; { status values for open files }
IOAVAIL = 1;
IOREAD = 2;
IOWRITE = 3;
{ universal manifest constants }
NULL = 0;
ENDSTR = -1 ; { null-terminated strings }
ENDFILE = -2 ;
ENDOFQIO = -3 ;
MAXSTR = 100; { longest possible string }
CONLENGTH = 20;
{ ascii character set in decimal }
BACKSPACE = 8;
TAB = 9;
NEWLINE = 10;
BLANK = 32;
EXMARK = 33;
SHARP = 35;
AMPERSAND = 38;
PERIOD = 46;
RABRACK = 62;
QUESTION = 63;
GRAVE = 96;
TILDE = 126;
LETA = 65;
LETZ = 90;
LETsa = 97;
LETsz = 122;
LET0 = 48;
LET9 = 57;
SOH = 1; { ascii SOH character }
CR = 13; { CR }
DEL = 127; { rubout }
DEFTRY = 5; { default for number of retries }
DEFITRY = 10; { default for number of retries on init }
DEFTIMEOUT = 20; { default time out }
DEFDELAY = 10 ; { delay before sending first init }
NUMPARAM = 7; { number of parameters in init packet }
DEFQUOTE = SHARP; { default quote character }
DEFEBQUOTE = AMPERSAND;
DEFPAD = 0; { default number of padding chars }
DEFPADCHAR = 0; { default padding character }
{ SYSTEM DEPENDENT }
DEFEOL = CR;
{ packet TYPES }
TYPEB = 66; { ord('B') }
TYPED = 68; { ord('D') }
TYPEE = 69; { ord('E') }
TYPEF = 70; { ord('F') }
TYPEN = 78; { ord('N') }
TYPES = 83; { ord('S') }
TYPET = 84; { ord('T') }
TYPEY = 89; { ord('Y') }
TYPEZ = 90; { ord('Z') }
MAXCMD = 10;
LineInSize = 512;
{ Command parser constants }
SMALLSIZE = 13;
LARGESIZE = 80;
MINPACKETSIZE = 10;
MAXPACKETSIZE = 94;
{ %include 'CURRENT_CONSTANT' (lines 105-395)}
NULLTOKE = 100;
RANGENULL = 101;
KERMITPROMPT = 'Kermit-CP6>';
KERMITHELP = 'KERMITHLP:';
INVALIDCOMMAND = 1;
INVALIDSETCOMMAND = 2;
INVALIDSHOWCOMMAND = 3;
NOTIMPLEMENTED = 4;
INVALIDFILESPEC = 5;
INVALIDSETCVALUE = 6;
INVALIDSETDVALUE = 7;
INVALIDSETOVALUE = 8;
INVALIDSETRANGE = 9;
SENDPARMS = 10;
RECEIVEPARMS = 11;
LOCALPARMS = 12;
BLANKLINE = 13;
NOHELPAVAILABLE = 14;
IBEXSPAWNFAILED = 15;
cSET = 'SET ';
cSHOW = 'SHOW ';
cSTATUS = 'STATUS ';
cCONNECT = 'CONNECT ';
cHELP = 'HELP ';
cEXIT = 'EXIT ';
cQUIT = 'QUIT ';
cQUESTION = '? ';
cSEND = 'SEND ';
cRECEIVE = 'RECEIVE ';
cDEBUGGING = 'DEBUGGING ';
cLOCALECHO = 'LOCAL-ECHO ';
cDELAY = 'DELAY ';
cPACKETLENGTH = 'PACKET-LENGTH';
cPADDING = 'PADDING ';
cPADCHAR = 'PADCHAR ';
cTIMEOUT = 'TIMEOUT ';
cENDOFLINE = 'END-OF-LINE ';
cQUOTE = 'QUOTE ';
cALL = 'ALL ';
cON = 'ON ';
cOFF = 'OFF ';
cBADTOKEN = 'XX ';
cTRANSMODE = 'TRANSMODE ';
cASCII = 'ASCII ';
cBINARY = 'BINARY ';
cEIGHTQUOTE = 'EIGHT-QUOTE ';
cFILERECORD = 'FILERECORD ';
cCR = 'CR ';
cLF = 'LF ';
cCRLF = 'CRLF ';
cPARITY = 'PARITY ';
cEVEN = 'EVEN ';
cODD = 'ODD ';
cNONE = 'NONE ';
cSPEED = 'SPEED ';
cIBEX = 'IBEX ';
uSET = 3;
uMSEND = 3;
uMRECEIVE = 1;
uSHOW = 2;
uSTATUS = 2;
uCONNECT = 1;
uIBEX = 1;
uHELP = 1;
uQUESTION = 1;
uEXIT = 1;
uQUIT = 1;
uSEND = 1;
uRECEIVE = 1;
uDEBUGGING = 3;
uFILERECORD = 1;
uTRANSMODE = 1;
uLOCALECHO = 2;
uDELAY = 3;
uPACKETLENGTH = 3;
uPADDING = 4;
uPADCHAR = 4;
uTIMEOUT = 1;
uENDOFLINE = 1;
uQUOTE = 1;
uALL = 1;
uON = 2;
uOFF = 2;
uBADTOKEN = 1;
uCR = 2;
uLF = 1;
uCRLF = 2;
uPARITY = 1;
uEVEN = 1;
uODD = 1;
uNONE = 1;
uSPEED = 2;
uASCII = 1;
uBINARY = 1;
uQUOTED = 1;
uEIGHTQUOTE = 1;
oON = 0;
oOFF = 1;
oEVEN = 2;
oODD = 3;
oNONE = 4;
oSET = 5;
oSHOW = 6;
oSTATUS = 7;
oCONNECT = 8;
oHELP = 9;
oEXIT = 10;
oQUIT = 11;
oSEND = 12;
oRECEIVE = 13;
oDEBUGGING = 14;
oLOCALECHO = 15;
oDELAY = 16;
oPACKETLENGTH = 17;
oPADDING = 18;
oPADCHAR = 19;
oTIMEOUT = 20;
oENDOFLINE = 21;
oQUOTE = 22;
oQUESTIONM = 23;
oALL = 24;
oBADTOKEN = 25;
oFILERECORD = 26;
oCR = 27;
oLF = 28;
oCRLF = 29;
oPARITY = 30;
oSPEED = 31;
oIBEX = 32;
oTRANSMODE = 33;
oASCII = 34;
oBINARY = 35;
oEIGHTQUOTE = 36;
oXXXX = 100 ;
oMAINTYPE = 1;
oSETTYPE = 2;
oSHOWTYPE = 3;
oSENDTYPE = 4;
oRECEIVETYPE = 5;
oDEBUGTYPE = 6;
oFILERECTYPE = 8;
oLOCECHOTYPE = 9;
oPARITYTYPE = 10;
oTRANSTYPE = 11;
DECIMAL = 0;
SDECIMAL = 1;
OCTAL = 2;
CHRACTER = 3;
IDECIMAL = 4;
EBCHRACTER = 5;
oASCSTATE = 1;
oBINSTATE = 0;
o300BAUD = 300;
o600BAUD = 600;
o1200BAUD = 1200;
o2400BAUD = 2400;
o4800BAUD = 4800;
o9600BAUD = 9600;
type
character = ENDOFQIO..255; { byte-sized. ascii + other stuff }
schar = -128..127;
wordInteger = 0..65535;
string = array [1..MAXSTR] of character;
vstring = record
len : integer;
ch : array [1..MAXSTR] of char;
end;
cstring = PACKED array [1..CONLENGTH] of char;
IOstate = IOERROR..IOWRITE;
filedesc = (keyboard,screen,RS232,history,outfile,infile) ;
IOBUFFER = packed array[1..LineInSize] of character ;
{ Eight bit file stuff }
EBQtype = (Ascii, Binary);
SevenEight =
RECORD
CASE mode : EBQtype OF
Ascii : ( seven : CHAR );
Binary : ( eight : 0..255 )
END ;
{ Data TYPES for Kermit }
Packet = RECORD
mark : character; { SOH character }
count: character; { # of bytes following this field }
seq : character; { sequence number modulo 64 }
ptype: character; { d,y,n,s,b,f,z,e,t packet type }
data : string; { the actual data }
end;
{ chksum is last validchar in data array }
{ eol is added, not considered part of packet proper }
Command = (Transmit,Receive,Invalid,Connect);
KermitStates = (FileData,Init,Break,FileHeader,EOFile,Complete,Abort);
EOLtype = (LineFeed,CrLf,JustCr);
Stats = integer;
Ppack = ^Packet;
Intype = (nothing,CRin,abortnow);
{ Parser defined types }
vmsString = packed array [1..255] of char;
string13 = packed array [1..SMALLSIZE] of char;
string80 = packed array [1..LARGESIZE] of char;
NewString80 =
record
StringPart : packed array [1..80] of char;
LengthOfSP : 0..80
end;
var
cmdargs : 0..MAXCMD;
LINE,ERRORS,DiskOutFile,DiskInFile : text;
file3cnt, file4cnt : integer;
{ varibles for Kermit }
DiskFile : IOstate ; { File being read/written }
SaveState : kermitstates;
NextArg : integer; { next argument to process }
local : boolean; { local/remote flag }
MaxTry : integer;
n : integer; { packet number }
NumTry : integer; { times this packet retried }
OldTry : integer;
Delay : integer;
Pad, MyPad : integer; { number of padding characters I need }
PadChar, MyPadChar: INTEGER;
MyTimeOut, TheirTimeOut : integer;
timeOutStatus : boolean;
Runtype, oldRunType : command;
State : kermitstates;
STDERR, LineOUT, ControlIN, ControlOUT : filedesc;
SizeRecv, SizeSend : integer;
SendEOL, SendQuote : INTEGER;
myEOL,myQuote: INTEGER;
EOLFORFILE : EOLtype;
NumSendPacks, NumRecvPacks : integer;
NumACK, NumNAK : integer;
NumACKrecv, NumNAKrecv, NumBADrecv : integer;
RunTime : integer;
ChInFileRecv, ChInPackRecv, ChInFileSend, ChInPackSend : Stats;
Debug : boolean;
ThisPacket : Ppack; { current packet being sent }
LastPacket : Ppack; { last packet sent }
CurrentPacket : Ppack; { current packet received }
NextPacket : Ppack; { next packet being received }
InputPacket : Ppack; { save input to do debug }
{ these are used for the Receive Packet procedures }
FromConsole : Intype ;
check: integer; { Checksum }
PacketPtr : integer; { pointer to InputPacket }
dataptr : integer; { pointer to data of Packet }
fld : 0..5; { current fld number }
t : character; { input character }
finished : boolean; { finished packet ? }
restart : boolean; { restart packet ? }
control : boolean; { quoted ? }
isgood : boolean; { packet is good ? }
IncomingPacket : IOBUFFER;
BufferPointer, BufferEnd : integer ;
{ Eight Bit Quoting Info }
sentEBQuote, recvdEBQuote, needEBQuote : boolean; { Used for determining 8 bit state }
EBQState : EBQtype; { ... }
EBQchar : INTEGER; { Quote character for 8 bit trans }
ishigh : integer; { Shift to put high bit on }
{ Parser defined variables }
commandLine : string80;
fileSpec : string80;
exitProgram : boolean;
localEcho, sFileSpec, rFileSpec, lSpeed, transtype : integer;
escape, debugging, commandLen, fileEol, parity : integer;
width, linespeed : integer ;
MAXPACK : 0..MAXPACKETSIZE ; {number of characters must be less }
{than platen width-otherwise LF is inserted}
DEFPARITY : integer ;
PROCEDURE Take_Nap (seconds : integer) ; external ;
PROCEDURE set_profile (mode : integer ; {0=get,1=restore}
var linespeed : integer ;
var width : integer ; {max line before wrap-around}
var parity : integer ) ; external ;
PROCEDURE set_prompt {NO PROMPT} ; external ;
PROCEDURE set_parity (parity : integer) ; external ;
function ReadCommLine (var IncomingPacket : IOBUFFER ;
N : integer ;
timeout : integer ;
var status : boolean ;
var endofline : integer ;
var start : integer ) : integer ;
type line = packed array [1..LineInSize] of char ;
var Buffer : line ;
ChValue : SevenEight ;
k : integer ;
EOL : char;
PROCEDURE getlineinput (var Buffer : line ;
LENGTH : integer ;
wait : integer ; {timeout seconds}
var status : boolean ) ; external ;
begin
EOL := chr (endofline) ;
for k := 1 to LineInSize do Buffer[k] := EOL ;
start := 0 ;
ReadCommLine := 0;
getlineinput (Buffer, LineInSize, timeout, status) ;
begin
k := 1 ;
while (k <= LineInSize) and (Buffer[k] <> EOL) do
begin
ReadCommLine := k ;
ChValue.seven := Buffer[k] ;
IncomingPacket[k] := ChValue.eight ;
k := k + 1
end ;
end
end;
function min (a,b: integer) : integer ;
begin if a <= b then
min := a
else
min := b
end ;
function max (a,b: integer) : integer ;
begin if a >= b then
max := a
else
max := b
end ;
procedure GetCf(var c:character);
var
ch : SevenEight ;
begin
if not eof(DiskInFile) then
if eoln(DiskInFile) then
begin
readln(DiskInFile);
c := NEWLINE
end
else
begin
read(DiskInFile, ch.seven) ;
c := ch.eight
end
else
c := ENDFILE
end;
procedure DebugMessage(c : cstring);
forward;
procedure PutCln(x:cstring;
fd:filedesc);
forward;
procedure AddTo(var sum : Stats;
inc:integer);
forward;
procedure PutCN(x:cstring;
v : integer;
fd:filedesc);
forward;
procedure FinishUp(noErrors : boolean);
forward;
procedure ErrorPack(c:cstring);
forward;
procedure ProgramHalt; { used by external procedures for halt }
begin
GOTO 9999
end;
function FileOpen (FileName : string80 ; mode : filedesc) : IOstate ;
begin
case mode of
infile : begin
Set_File_Parameters (DiskInFile, FileName,
'DCB = DISKINFILE, ERROR=CONTINUE') ;
reset (DiskInFile) ;
if File_Status (DiskInFile) = 0 then
FileOpen := IOREAD
else
FileOpen := IOERROR
end ;
outfile : begin
Set_File_Parameters (DiskOutFile, FileName,
'DCB = DISKOUTFILE, CTG = YES') ;
rewrite (DiskOutFile ) ;
FileOpen := IOWRITE ;
end ;
end {case}
end;
procedure Sclose (var fd : IOstate);
begin
case fd of
IOREAD: Close_file (DiskInFile) ;
IOWRITE: Close_file (DiskOutFile)
end {case};
fd := IOAVAIL
end;
procedure Putcf (c : character; fd : filedesc);
var byte : SevenEight ;
BEGIN
CASE FD OF
screen:
IF (C=NEWLINE) THEN
WRITELN(OUTPUT)
ELSE
WRITE(OUTPUT,CHR(C));
history:
IF (C=NEWLINE) THEN
WRITELN(ERRORS)
ELSE
WRITE(ERRORS,CHR(C));
RS232: WRITE(LINE,CHR(C));
outfile:
IF (C=NEWLINE) THEN
WRITELN(DiskOutFile)
ELSE
begin
byte.eight := c ;
WRITE(DiskOutFile, byte.seven)
end
END;
END;
function getc (var c : character) : character;
{ getc (UCB) -- get one character from standard input }
var
ch : char;
begin
if eof then
c := ENDFILE
else
if eoln then
begin
readln;
c := NEWLINE
end
else
begin
read(ch);
c := ord(ch)
end;
getc := c
end;
procedure Putc (c : character);
{ putc (UCB) -- put one character on standard output }
begin
if c = NEWLINE then
writeln
else
write(chr(c));
end;
procedure PutStr (var s : string; f : filedesc);
{ putstr (UCB) -- put out string on file }
var
i : integer;
begin
i := 1;
while (s[i] <> ENDSTR) do
begin
Putcf(s[i], f);
i := i + 1
end
end;
function ItoC (n : integer; var s : string; i : integer)
: integer; { returns end of s }
{ ItoC - convert integer n to char string in s[i]... }
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;
function LengthSTIP (var s : string) : integer;
{ lengthSTIP -- compute length of string }
var
n : integer;
begin
n := 1;
while (s[n] <> ENDSTR) do
n := n + 1;
LengthSTIP := n - 1
end;
procedure Scopy (var src : string; i : integer;
var dest : string; j : integer);
{ scopy -- copy string at src[i] to dest[j] }
begin
while (src[i] <> ENDSTR) do
begin
dest[j] := src[i];
i := i + 1;
j := j + 1
end;
dest[j] := ENDSTR
end;
function IsUpper (c : character) : boolean;
{ isupper -- true if c is upper case letter }
begin
isupper := (c >= ord('A')) and (c <= ord('Z'))
end;
function IndexSTIP (var s : string; c : character) : integer;
{ IndexSTIP -- find position of character c in string s }
var
i : integer;
begin
i := 1;
while (s[i] <> c) and (s[i] <> ENDSTR) do
i := i + 1;
if (s[i] = ENDSTR) then
IndexSTIP := 0
else
IndexSTIP := i
end;
procedure CtoS(x:cstring; var s:string);
{ convert constant to STIP string }
var
i : integer;
begin
for i:=1 to CONLENGTH do
s[i] := ord(x[i]);
s[CONLENGTH+1] := ENDSTR;
end;
procedure PutCon(x:cstring;
fd:filedesc);
{ output literal }
var
s: string;
begin
CtoS(x,s);
PutStr(s,fd);
end;
procedure PutCln;
{ output literal followed by NEWLINE }
begin
PutCon(x,fd);
Putcf(NEWLINE,fd);
end;
procedure PutNum(n:integer;
fd:filedesc);
{ Ouput number }
var
s: string;
dummy: integer;
begin
s[1] := BLANK;
dummy := ItoC(n,s,2);
PutStr(s,fd);
end;
procedure PutCS(x:cstring;
s : string;
fd:filedesc);
{ output literal & string }
begin
PutCon(x,fd);
PutStr(s,fd);
Putcf(NEWLINE,fd);
end;
procedure PutCN;
{ output literal & number }
begin
PutCon(x,fd);
PutNum(v,fd);
Putcf(NEWLINE,fd);
end;
procedure AddTo;
begin
sum := sum + inc;
end;
procedure OverHd(p,f: Stats;
var o:integer);
{ Calculate OverHead as % }
{ 0verHead := (p-f)*100/f }
begin
if (f <> 0) then
o := ((p - f)*100) div f
else
o := 100;
end;
procedure CalRat(f: Stats;
t:integer;
var r:integer);
{ Calculate Effective Baud Rate }
{ Rate = f*10/t }
begin
if (t <> 0) then
r := (f * 10) div t
else
r := 0;
end;
procedure DebugMessage;
{ Print writeln if debug }
begin
if debug then
PUTCLN(C,STDERR);
end;
procedure DebugMessNumb(s : cstring; val : integer);
{ Print message and a number }
begin
if debug then
begin
Putcln(s, STDERR);
PutNum(val, STDERR);
end;
end;
procedure PutPacket(p : Ppack); { Output Packet }
var
i : integer;
begin
DebugMessage('PutPacket... ');
if (Pad >0) then
for i := 1 to Pad do
Putcf(PadChar,LineOut);
with p^ do
begin
Putcf(mark,LineOut);
Putcf(count,LineOut);
Putcf(seq,LineOut);
Putcf(ptype,LineOut);
PutStr(data,LineOut);
end;
Putcf(NEWLINE,LineOut) ;
end;
function GetIn : character; { get character }
{ Should return NULL ( ENDSTR ) if no characters }
var
c : character;
begin
BufferPointer := BufferPointer + 1;
if (BufferPointer <= BufferEnd) then
c := IncomingPacket[BufferPointer]
else
c := ENDOFQIO;
GetIn := c;
if (c <> NULL) then
AddTo(ChInPackRecv,1)
end;
function MakeChar(c:character): character;
{ convert integer to printable }
begin
MakeChar := c+BLANK;
end;
function UnChar(c:character): character;
{ reverse of makechar }
begin
UnChar := c - BLANK
end;
function IsControl(c:character): boolean;
{ true if control }
begin
if (c >= NULL) then
IsControl := (c = DEL ) or (c < BLANK )
else
IsControl := IsControl(c + 128);
end;
function Ctl(c:character): character;
{ c XOR 100 }
begin
if (c >= NULL) then
if (c < 64) then
c := c + 64
else
c := c-64
else
c := Ctl(c + 128) - 128;
Ctl := c;
end;
function Checkfunction(c:integer): character;
{ calculate checksum }
var
x: integer;
begin
DebugMessage('Checkfunction... ');
{ Checkfunction := (c + ( c and 300 ) /100 ) and 77; }
x := (c MOD 256 ) DIV 64;
x := x+c;
Checkfunction := x MOD 64;
end;
procedure SetEBQuoteState;
begin
if (EBQState = Binary) then
begin
transType := oBINARY;
end
else
begin
transType := oASCII;
end;
end;
procedure EnCodeParm(var data:string); { encode parameters }
var
i: integer;
begin
DebugMessage('EnCodeParm... ');
for i:=1 to NUMPARAM do
data[i] := BLANK;
data[NUMPARAM+1] := ENDSTR;
data[1] := MakeChar(SizeRecv); { my biggest packet }
data[2] := MakeChar(MyTimeOut); { when I want timeout}
data[3] := MakeChar(MyPad); { how much padding }
data[4] := Ctl(MyPadChar); { my padding character }
data[5] := MakeChar(myEOL); { my EOL }
data[6] := MyQuote; { my quote char }
{ Handle eight bit quoting parm }
case RunType of
Transmit :
if EBQState = Binary then
begin
if EBQChar <> DEFEBQUOTE then
begin
data[7] := EBQChar;
sentEBQuote := true;
end
else
data[7] := TYPEY;
end
else
data[7] := TYPEN;
Receive :
if EBQState = Binary then
begin
if recvdEBQuote then
data[7] := TYPEY
else
if needEBQuote then
data[7] := EBQChar
else
begin
EBQState := Ascii;
data[7] := TYPEN;
end;
end
else
data[7] := TYPEN;
end;
SetEBQuoteState;
end;
function CheckEBQuote(inchr : character;
var outchr : INTEGER) : EBQtype;
begin
if (inchr in [EXMARK..RABRACK, GRAVE..TILDE]) then
begin
outchr := inchr;
CheckEBQuote := Binary
end
else
CheckEBQuote := Ascii;
end;
procedure DeCodeParm(var data:string); { decode parameters }
var
InEBQChar : character;
begin
DebugMessage('DeCodeParm... ');
SizeSend := UnChar(data[1]);
TheirTimeOut := UnChar(data[2]); { when I should time out }
Pad := UnChar(data[3]); { padding characters to send }
PadChar := Ctl(data[4]); { padding character }
SendEOL := UnChar(data[5]); { EOL to send }
SendQuote := data[6]; { quote to send }
{ Handle eight bit quoting parm }
InEBQchar := data[7];
case RunType of
Transmit :
if EBQState = Binary then
begin
if sentEBQuote then
begin
if InEBQchar <> TYPEY then
EBQState := Ascii;
end
else
if InEBQchar = TYPEN then
EBQState := Ascii
else
EBQState := CheckEBQuote(InEBQchar, EBQchar);
end;
Receive :
if EBQState = Binary then
begin
if InEBQchar = TYPEY then
needEBQuote := true
else
if InEBQchar = TYPEN then
EBQState := Ascii
else
begin
EBQState := CheckEBQuote(InEBQchar, EBQchar);
if EBQState = Binary then
recvdEBQuote := true;
end;
end;
end;
SetEBQuoteState;
end;
procedure StartRun; { initialization as necessary }
begin
DebugMessage('StartRun... ');
NumSendPacks := 0;
NumRecvPacks := 0;
NumACK := 0;
NumNAK := 0;
NumACKrecv := 0;
NumNAKrecv := 0;
NumBADrecv := 0;
ChInFileRecv := 0;
ChInFileSend := 0;
ChInPackRecv := 0;
ChInPackSend := 0;
State := Init; { send initiate is the start state }
NumTry := 0; { say no tries yet }
end;
procedure ResetKermitPacketNumber;
begin
n := 0;
end;
procedure KermitInit; { initialize various parameters & defaults }
VAR platen : integer ;
begin
set_prompt ;
set_file_parameters (line,' ','ORG = TERMINAL') ;
set_profile (0, {save terminal characteristics}
linespeed, {connect baud rate}
platen, {total packet most be smaller than this}
DEFPARITY) ; {connect parity}
case linespeed of
0,1,3,8,10,11 : {not support by CP_6} lSpeed := 0 ;
2,4,5,6 : lSpeed := o300BAUD ;
7 : lSpeed := o600BAUD ;
9 : lSpeed := o1200BAUD ;
12 : lSpeed := o2400BAUD ;
13 : lSpeed := o4800BAUD ;
14,15 : lSpeed := o9600BAUD ;
end {case} ;
MAXPACK := MAXPACKETSIZE ;
REWRITE(LINE);
REWRITE(ERRORS);
Pad := DEFPAD; { set defaults }
MyPad := DEFPAD;
PadChar := DEFPADCHAR;
MyPadChar := DEFPADCHAR;
TheirTimeOut := DEFTIMEOUT;
MyTimeOut := DEFTIMEOUT;
Delay := DEFDELAY;
SizeRecv := MAXPACKETSIZE ;
SizeSend := MAXPACK;
SendEOL := DEFEOL;
MyEOL := DEFEOL;
SendQuote := DEFQUOTE;
MyQuote := DEFQUOTE;
EBQChar := DEFEBQUOTE;
MaxTry := DEFITRY;
localEcho := oOFF;
parity := DEFPARITY ;
fileEol := oCRLF;
transtype := oASCII;
Local := true ; { default to local }
Debug := false;
debugging := oOFF;
Runtype := invalid;
DiskFile := IOERROR; { to indicate not open yet }
STDERR := history ;
LineOUT := RS232 ;
ControlIN := keyboard ;
ControlOUT := screen ;
new(ThisPacket);
new(LastPacket);
new(CurrentPacket);
new(NextPacket);
new(InputPacket);
NumSendPacks := 0;
NumRecvPacks := 0;
NumACK := 0;
NumNAK := 0;
NumACKrecv := 0;
NumNAKrecv := 0;
NumBADrecv := 0;
ChInFileRecv := 0;
ChInFileSend := 0;
ChInPackRecv := 0;
ChInPackSend := 0;
NumTry := 0; { say no tries yet }
OldRunType := connect ;
EBQState := Ascii ;
end;
procedure FinishUp;
{ do any end of transmission clean up }
begin
DebugMessage('FinishUp... ');
{Sclose(DiskFile);}
if not(noErrors) then
else
begin
ErrorPack('Aborting Transfer ');
end;
oldRunType := RunType;
PutCf(NEWLINE, ControlOUT);
end;
procedure DebugPacket(mes : cstring;
var p : Ppack);
{ Print Debugging Info }
begin
DebugMessage('DebugPacket... ');
PutCon(mes,STDERR);
with p^ do
begin
PutNum(Unchar(count),STDERR);
PutNum(Unchar(seq),STDERR);
Putcf(BLANK,STDERR);
Putcf(ptype,STDERR);
Putcf(NEWLINE,STDERR);
PutStr(data,STDERR);
Putcf(NEWLINE,STDERR);
end;
end;
procedure ReSendPacket;
{ re -sends previous packet }
begin
DebugMessage('ReSendPacket... ');
NumSendPacks := NumSendPacks+1;
if Debug then
DebugPacket('Re-Sending ... ',LastPacket);
PutPacket(LastPacket);
end;
procedure SendPacket;
{ expects count as length of data portion }
{ and seq as number of packet }
{ builds & sends packet }
var
i,len,chksum : integer;
temp : Ppack;
begin
DebugMessage('Sending Packet ');
if (NumTry <> 1) and (Runtype = Transmit ) then
ReSendPacket
else
begin
with ThisPacket^ do
begin
mark := SOH; { mark }
len := count; { save length }
count := MakeChar(len+3); { count = 3+length of data }
seq := MakeChar(seq); { seq number }
chksum := count + seq + ptype;
if ( len > 0) then { is there data ? }
for i:= 1 to len do
if (data[i] >= 0) then
chksum := chksum + data[i] { loop for data }
else
chksum := chksum + data[i] + 256;
chksum := Checkfunction(chksum); { calculate checksum }
data[len+1] := MakeChar(chksum); { make printable & output }
data[len+2] := SendEOL; { EOL }
data[len+3] := ENDSTR;
end;
NumSendPacks := NumSendPacks+1;
if Debug then
DebugPacket('Sending ... ',ThisPacket);
PutPacket(ThisPacket);
if Runtype = Transmit then
begin
temp := LastPacket;
LastPacket := ThisPacket;
ThisPacket := temp;
end;
end;
end;
procedure SendACK(n:integer); { send ACK packet }
begin
DebugMessage('SendAck... ');
with ThisPacket^ do
begin
count := 0;
seq := n;
ptype := TYPEY;
end;
SendPacket;
NumACK := NumACK+1;
end;
procedure SendNAK(n:integer); { send NAK packet }
begin
DebugMessage('SendNAK... ');
with ThisPacket^ do
begin
count := 0;
seq := n;
ptype := TYPEN;
end;
SendPacket;
NumNAK := NumNAK+1;
end;
procedure ErrorPack;
{ output Error packet if necessary -- then exit }
begin
DebugMessage('ErrorPack... ');
with ThisPacket^ do
begin
seq := n;
ptype := TYPEE;
CtoS(c,data);
count := LengthSTIP(data);
end;
SendPacket;
end;
procedure PutErr(c:cstring);
{ Print error_messages }
begin
DebugMessage('PutErr... ');
if debug then
Putcln(c,STDERR);
end;
procedure Field1; { Count }
var
test: boolean;
begin
DebugMessage('Field1... ');
with NextPacket^ do
begin
InputPacket^.count := t;
count := UnChar(t);
test := (count >= 3) or (count <= SizeRecv-2);
if not test then
DebugMessage('Bad count ');
isgood := isgood and test;
end;
end;
procedure Field2; { Packet Number }
var
test : boolean;
begin
DebugMessage('Field2... ');
with NextPacket^ do
begin
InputPacket^.seq := t;
seq := UnChar(t);
test := (seq >= 0) or (seq <= 63);
if not test then
DebugMessage('Bad seq number ');
isgood := isgood and test;
end;
end;
procedure Field3; { Packet type }
var
test : boolean;
begin
DebugMessage('Field3... ');
with NextPacket^ do
begin
ptype := t;
InputPacket^.ptype := t;
test := (t =TYPEB) or (t=TYPED) or (t=TYPEE) or (t=TYPEF)
or (t=TYPEN) or (t=TYPES) or (t=TYPEY) or (t=TYPEZ);
if not test then
DebugMessage('Bad Packet type ');
isgood := isgood and test;
end;
end;
procedure ProcessQuoted; { for data }
begin
with NextPacket^ do
begin
if (t = MyQuote) or ((t = EBQchar) and (EBQState = Binary)) then
begin
if control then
begin
data[dataptr] := t + ishigh;
dataptr := dataptr + 1;
control := false;
ishigh := 0;
end
else
if (t = MyQuote) then { Set Control on }
control := true;
end
else
if control then
begin
data[dataptr] := ctl(t) + ishigh;
dataptr := dataptr + 1;
control := false;
ishigh := 0;
end
else
begin
data[dataptr] := t + ishigh;
dataptr := dataptr + 1;
ishigh := 0;
end;
end;
end;
procedure Field4; { Data }
begin
PacketPtr := PacketPtr+1;
InputPacket^.data[PacketPtr] := t;
with NextPacket^ do
begin
if ((pType = TYPES) or (pType = TYPEY)) then
begin
data[dataptr] := t;
dataptr := dataptr+1;
end
else
begin
if (EBQstate = Binary) then
begin { Has it been quoted }
if (not(control) and (t = EBQchar)) then
ishigh := 128
else
ProcessQuoted;
end
else
ProcessQuoted;
end;
end;
end;
procedure Field5; { Check Sum }
var
test : boolean;
begin
DebugMessage('Field5... ');
with InputPacket^ do
begin
PacketPtr := PacketPtr +1;
data[PacketPtr] := t;
PacketPtr := PacketPtr +1;
data[PacketPtr] := ENDSTR;
end;
{ end of input string }
check := Checkfunction(check);
check := MakeChar(check);
test := (t=check);
if not test then
DebugMessNumb('Bad CheckSum= ', check);
isgood := isgood and test;
NextPacket^.data[dataptr] := ENDSTR;
{ end of data string }
finished := true; { set finished }
end;
procedure BuildPacket;
{ receive packet & validate checksum }
var
temp : Ppack;
begin
with NextPacket^ do
begin
if restart then
begin
{ read until get SOH marker }
if (t = SOH) then
begin
finished := false; { set varibles }
control := false;
ishigh := 0; { no shift }
isgood := true;
seq := -1; { set return values to bad packet }
ptype := QUESTION;
data[1] := ENDSTR;
data[MAXSTR] := ENDSTR;
restart := false;
fld := 0;
dataptr := 1;
PacketPtr := 0;
check := 0;
end;
end
else { have started packet }
begin
if (t=SOH) then
restart := true
else
if (t=myEOL) then
begin
finished := true;
isgood := false;
end
else
begin
case fld of
{ increment field number }
0: fld := 1;
1: fld := 2;
2: fld := 3;
3:
if (count=3) then
fld := 5
else
fld := 4;
4:
if (PacketPtr>=count-3) then
fld := 5;
end { case };
if (fld<>5) then
{ add into checksum }
check := check+t;
case fld of
1: Field1;
2: Field2;
3: Field3;
4: Field4;
5: Field5;
end; { case }
end;
end;
if finished then
begin
if (ptype=TYPEE) and isgood then { error_packets }
begin
if Local then
PutStr(data,STDERR);
Putcf(NEWLINE,STDERR);
FinishUp(false);
ProgramHalt;
end;
NumRecvPacks := NumRecvPacks+1;
if Debug then
begin
DebugPacket('Received ... ',InputPacket);
if isgood then
PutCln('Is Good ',STDERR);
end;
temp := CurrentPacket;
CurrentPacket := NextPacket;
NextPacket := temp;
end;
end;
end;
function ReceivePacket: boolean;
begin
DebugMessage('ReceivePacket... ');
finished := false;
restart := true;
FromConsole := nothing; { No Interupt }
{ Obtain packet from VMS incoming channel }
BufferEnd :=
ReadCommLine(IncomingPacket,LineInSize,theirtimeout,timeoutstatus,
MYEOL,BufferPointer) ;
{ Check local terminal for abort, resend character }
if local then
begin
{CheckTypeAhead(FromConsole);}
FROMCONSOLE := NOTHING;
case FromConsole of
abortnow:
begin
FinishUp(true);
ProgramHalt;
end;
nothing: { nothing };
CRin:
begin
t := MyEOL;
FromConsole := nothing;
end;
end;
end;
if (BufferEnd = 0) then
begin
ReceivePacket := false;
if (timeOutStatus) then
begin
CurrentPacket^.ptype := TYPET;
restart := true;
if (debug) then
PutCln('Timed Out ', STDERR)
end;
end
else
begin
repeat
t := GetIn;
if (t<>ENDOFQIO) then
BuildPacket
else
begin
finished := true;
isgood := false;
end;
until finished;
ReceivePacket := isgood;
end;
end;
function ReceiveACK : boolean;
{ receive ACK with correct number }
var
Ok: boolean;
begin
DebugMessage('ReceiveACK... ');
Ok := ReceivePacket;
with CurrentPacket^ do
begin
if (ptype=TYPEY) then
NumACKrecv := NumACKrecv+1
else
if (ptype=TYPEN) then
NumNAKrecv := NumNAKrecv+1
else
NumBadrecv := NumBadrecv +1;
{ got right one ? }
ReceiveACK := ( Ok and (ptype=TYPEY) and (n=seq))
end;
end;
procedure GetData(var newstate:KermitStates);
{ get data from file into ThisPacket }
var
{ and return next state - data & EOF }
x,c : character;
i: integer;
begin
DebugMessage('GetData... ');
if (NumTry=1) then
begin
i := 1;
x := ENDSTR;
with ThisPacket^ do
begin
while (i< SizeSend - 8 ) and (x <> ENDFILE) do
{ leave room for quote & NEWLINE }
begin
GetCf (x) ;
if (x<>ENDFILE) then
begin
if (x < NULL) then
case EBQstate of
ascii :
ErrorPack('No Binary Support ');
binary :
begin
data[i] := EBQchar;
i := i + 1;
x := x + 128;
end;
end;
if (IsControl(x)) or (x=SendQuote) or
((x = EBQchar) and (EBQState = Binary)) then
begin { control char -- quote }
if ((x=NEWLINE) and
(EBQState <> Binary)) then
case EOLFORFILE of
LineFeed: { ok as is };
CrLf:
begin
data[i] := SendQuote;
i := i+1;
data[i] := Ctl(CR);
i := i+1;
{ LF will sent below }
end;
JustCR:
x := CR;
end { case };
data[i] := SendQuote;
i := i+1;
if (x<>SendQuote) or (x <> EBQchar) then
data[i] := Ctl(x)
else
data[i] := x;
end
else { regular char }
data[i] := x;
end;
if (x<>ENDFILE) then
begin
i := i+1; { increase count for next char }
AddTo(ChInFileSend,1);
end;
end;
data[i] := ENDSTR; { to terminate string }
count := i -1; { length }
seq := n;
ptype := TYPED;
if (x=ENDFILE) then
begin
newstate := EOFile;
{Sclose(DiskFile);}
end
else
newstate := FileData;
SaveState := newstate; { save state }
end
end
else
newstate := SaveState; { get old state }
end;
function GetNextFile: boolean;
{ get next file to send in ThisPacket }
{there ain't no next file, this baby only sends one file at a time}
{ returns true if no more }
var
k : integer ;
result: boolean;
begin
DebugMessage('GetNextFile... ');
result := true;
if (NumTry=1) then
begin
if FileSpec[1] <> ' ' then
DiskFile := fileopen (filespec,infile) ;
with ThisPacket^ do
if DiskFile = IOREAD then
begin
k := 1;
while (FileSpec[k] <> ' ') and (FileSpec[k] <> '.') do
begin
data[k] := ord (FileSpec[k]) ;
FileSpec[k] := ' ';
data[k+1] := ENDSTR ;
k := k + 1
end ;
count := LengthSTIP(data);
AddTo(ChInFileSend , count);
seq := n;
ptype := TYPEF;
result := false;
end ;
end ;
GetNextFile := result;
end;
procedure SendFile; { send file name packet }
begin
DebugMessage('SendFile... ');
if NumTry > MaxTry then
begin
PutErr ('Send file - Too Many');
State := Abort; { too many tries, abort }
end
else
begin
NumTry := NumTry+1;
if GetNextFile then
begin
State := Break;
NumTry := 0;
end
else
begin
if debug then
begin
if (NumTry = 1) then
PutStr(ThisPacket^.data,STDERR)
else
PutStr(LastPacket^.data,STDERR);
Putcf(NEWLINE,STDERR);
end;
SendPacket; { send this packet }
if ReceiveACK then
begin
State := FileData;
NumTry := 0;
n := (n+1) MOD 64;
end
end;
end;
end;
procedure SendData; { send file data packets }
var
newstate: KermitStates;
begin
DebugMessage('SendData... ');
if debug then
PutCN ('Sending data ',n,STDERR);
if NumTry > MaxTry then
begin
State := Abort; { too many tries, abort }
PutErr ('Send data - Too many');
end
else
begin
NumTry := NumTry+1;
GetData(newstate);
SendPacket;
if ReceiveACK then
begin
State := newstate;
NumTry := 0;
n := (n+1) MOD 64;
end
end;
end;
procedure SendEOF; { send EOF packet }
begin
DebugMessage('SendEOF... ');
if NumTry > MaxTry then
begin
State := Abort; { too many tries, abort }
PutErr('Send EOF - Too Many ');
end
else
begin
NumTry := NumTry+1;
if (NumTry = 1) then
begin
with ThisPacket^ do
begin
ptype := TYPEZ;
seq := n;
count := 0;
end;
Sclose(DiskFile);
end;
SendPacket;
if ReceiveACK then
begin
State := FileHeader;
NumTry := 0;
n := (n+1) MOD 64;
end
end;
end;
procedure SendBreak; { send break packet }
begin
DebugMessage ('Sending break ');
if NumTry > MaxTry then
begin
State := Abort; { too many tries, abort }
PutErr('Send break -Too Many');
end
else
begin
NumTry := NumTry+1;
{ make up packet }
if NumTry = 1 then
begin
with ThisPacket^ do
begin
ptype := TYPEB;
seq := n;
count := 0;
end
end;
SendPacket; { send this packet }
if ReceiveACK then
State := Complete;
end;
end;
procedure SendInit; { send init packet }
begin
DebugMessage ('Sending init ');
if NumTry > MaxTry then
begin
State := Abort; { too many tries, abort }
PutErr('Cannot Initialize ');
end
else
begin
NumTry := NumTry+1;
if (NumTry = 1) then
begin
with ThisPacket^ do
begin
EnCodeParm(data);
count := NUMPARAM;
seq := n;
ptype := TYPES;
end
end;
SendPacket; { send this packet }
if ReceiveACK then
begin
with CurrentPacket^ do
begin
SizeSend := UnChar(data[1]);
TheirTimeOut := UnChar(data[2]);
Pad := UnChar(data[3]);
PadChar := Ctl(data[4]);
SendEOL := CR; { default to CR }
if (LengthSTIP(data) >= 5) then
if (data[5] <> 0) then
SendEOL := UnChar(data[5]);
SendQuote := SHARP; { default # }
if (LengthSTIP(data) >= 6) then
if (data[6] <> 0) then
SendQuote := data[6];
end;
State := FileHeader;
NumTry := 0;
MaxTry := DEFTRY; { use regular default now }
n := (n+1) MOD 64;
end;
end;
end;
procedure SendSwitch;
{ Send-switch is the state table switcher for sending files.
* It loops until either it is finished or a fault is encountered.
* Routines called by sendswitch are responsible for changing the state. }
begin
DebugMessage ('Send Switch ');
StartRun;
repeat
case State of
FileData: SendData; { data-send state }
FileHeader: SENDFILE; { send file name }
EOFile: SendEOF; { send end-of-file }
Init: begin Take_Nap (Delay); SendInit end ; { send initialize }
Break: SendBreak; { send break }
Complete: { nothing };
Abort: { nothing };
end { case };
until ( (State = Abort) or (State=Complete) );
end;
procedure GetFile(data:string);
{ create file from fileheader packet }
const UNDERSCORE = '_' ;
var
i, j : integer;
FileName : string80 ;
begin
DebugMessage ('GetFile... ');
with CurrentPacket^ do
begin
FileName[1] := '*' ;
for i := 2 to LARGESIZE do FileName[i] := ' ' ;
i := 1;
j := 1;
repeat
if (data[i] in [LETA..LETZ, LETsa..LETsz,
LET0..LET9, PERIOD]) then
begin
FileName[j] := chr (data[i]) ;
if data[i] = PERIOD then
FileName[j] := UNDERSCORE ;
j := j + 1 ; if j > LARGESIZE then j := LARGESIZE ;
end;
i := i + 1
until (data[i] = ENDSTR) ;
end;
if rFileSpec = oON then
begin
rFileSpec := oOFF ;
FileName := filespec
end ;
diskfile := fileopen (FileName, outfile)
end;
procedure ReceiveInit;
{ receive init packet }
{ respond with ACK and our parameters }
var
receiveStat : boolean;
begin
DebugMessage ('ReceiveInit... ');
if NumTry > MaxTry then
begin
State := Abort;
PutErr('Cannot receive init ');
end
else
begin
NumTry := NumTry+1;
receiveStat := ReceivePacket;
if (ReceiveStat and (CurrentPacket^.ptype = TYPES)) then
begin
n := CurrentPacket^.seq;
DeCodeParm(InputPacket^.data);
{ now send mine }
with ThisPacket^ do
begin
count := NUMPARAM;
seq := n;
Ptype := TYPEY;
EnCodeParm(data);
end;
SendPacket;
NumACK := NumACK+1;
State := FileHeader;
OldTry := NumTry;
NumTry := 0;
MaxTry := DEFTRY; { use regular default now }
n := (n+1) MOD 64
end
else
begin
if Debug then
PutCln('Received Bad init ',STDERR);
SendNAK(n);
end;
end;
end;
procedure DataToFile; { output to file }
var
len,i : integer;
temp : string;
begin
DebugMessage ('DataToFile... ');
with CurrentPacket^ do
begin
len := LengthSTIP(data);
AddTo(ChInFileRecv ,len);
if (EBQState <> Binary) then
case EOLFORFILE of
LineFeed:
PutStr(data,outfile);
CrLf:
begin { don't output CR }
for i:=1 to len do
if data[i] <> CR then
Putcf(data[i],outfile);
end;
JustCR:
begin { change CR to NEWLINE }
for i:=1 to len do
if data[i]=CR then
data[i] := NEWLINE;
PutStr(data,outfile);
end;
end
else
PutStr(data, outfile);
end;
end;
procedure dodata; { Process Data packet }
begin
DebugMessage ('DoData... ');
with CurrentPacket^ do
begin
if seq = ((n + 63) MOD 64) then
begin { data last one }
if OldTry>MaxTry then
begin
State := Abort;
PutErr('Old data - Too many ');
end
else
begin
SendACK(seq);
NumTry := 0;
end;
end
else
begin { data - this one }
if (n<>seq) then
SendNAK(n)
else
begin
DataToFile;
SendACK(n); { ACK }
OldTry := NumTry;
NumTry := 0;
n := (n+1) MOD 64;
end;
end;
end;
end;
procedure doFileLast; { Process File Packet }
begin { File header - last one }
DebugMessage ('DoFileLast... ');
if OldTry > MaxTry { tries ? } then
begin
State := Abort;
PutErr('Old file - Too many ');
end
else
begin
OldTry := OldTry+1;
with CurrentPacket^ do
begin
if seq = ((n + 63) MOD 64) then
{ packet number }
begin { send ACK }
SendACK(seq);
NumTry := 0
end
else
begin
SendNAK(n); { NAK }
end;
end;
end;
end;
procedure DoEOF; { Process EOF packet }
begin { EOF - this one }
DebugMessage ('DoEOF... ');
if CurrentPacket^.seq<>n then { packet number ? }
SendNAK(n) { NAK }
else
begin { send ACK }
Sclose(DiskFile); { close file }
SendACK(n);
OldTry := NumTry;
NumTry := 0;
n := (n+1) MOD 64; { next packet }
State := FileHeader; { change state }
end;
end;
procedure ReceiveData; { Receive data packets }
var
strend: integer;
good : boolean;
begin
DebugMessage ('ReceiveData... ');
if NumTry > MaxTry then { check number of tries }
begin
State := Abort;
if debug then
PutCN('Recv data -Too many ',n,STDERR);
end
else
begin
NumTry := NumTry+1; { increase number of tries }
good := ReceivePacket; { get packet }
with CurrentPacket^ do
begin
if debug then
PutCN('Receiving (Data) ',CurrentPacket^.seq,STDERR);
if ((ptype = TYPED) or (ptype=TYPEZ)
or (ptype=TYPEF)) and good then { check type }
case ptype of
TYPED: doData;
TYPEF: doFileLast;
TYPEZ: doEOF;
end { case }
else
begin
if Debug then
PutCln('Expected data pack ',STDERR);
SendNAK(n);
end;
end;
end;
end;
procedure doBreak; { Process Break packet }
begin { Break transmission }
DebugMessage ('DoBreak... ');
if CurrentPacket^.seq<>n then { packet number ? }
SendNAK(n) { NAK }
else
begin { send ACK }
SendACK(n) ;
State := Complete { change state }
end;
end;
procedure DoFile; { Process file packet }
begin { File Header }
DebugMessage ('DoFile... ');
with CurrentPacket^ do
begin
if seq<>n then { packet number ? }
SendNAK(n) { NAK }
else
begin { send ACK }
AddTo(ChInFileRecv, LengthSTIP(data));
GetFile(data); { get file name }
SendACK(n);
OldTry := NumTry;
NumTry := 0;
n := (n+1) MOD 64; { next packet }
State := FileData; { change state }
end;
end;
end;
procedure DoEOFLast; { Process EOF Packet }
begin { end of File Last One}
DebugMessage ('DoEOFLast... ');
if OldTry > MaxTry then
begin
State := Abort;
PutErr('Old EOF - Too many ');
end
else
begin
OldTry := OldTry+1;
with CurrentPacket^ do
begin
if seq =((n + 63 ) MOD 64) then
{ packet number }
begin { send ACK }
SendACK(seq);
Numtry := 0
end
else
begin
SendNAK(n); { NAK }
end
end;
end;
end;
procedure DoInitLast;
begin { Init Packet - last one }
DebugMessage ('DoInitLast... ');
if OldTry>MaxTry then
begin
State := Abort;
PutErr('Old init - Too many ');
end
else
begin
OldTry := OldTry+1;
if CurrentPacket^.seq = ((n + 63) MOD 64) then
{ packet number }
begin { send ACK }
with ThisPacket^ do
begin
count := NUMPARAM;
seq := CurrentPacket^.seq;
ptype := TYPEY;
EnCodeParm(data);
end;
SendPacket;
NumACK := NumACK+1;
NumTry := 0;
end
else
begin
SendNAK(n); { NAK }
end;
end;
end;
procedure ReceiveFile; { receive file packet }
var
good: boolean;
begin
DebugMessage ('ReceiveFile... ');
if NumTry > MaxTry then { check number of tries }
begin
State := Abort;
PutErr('Recv file - Too many');
end
else
begin
NumTry := NumTry+1; { increase number of tries }
good := ReceivePacket; { get packet }
with CurrentPacket^ do
begin
if debug then
PutCN('Receiving (File) ',seq,STDERR);
if ((ptype = TYPES) or (ptype=TYPEZ)
or (ptype=TYPEF) or (ptype=TYPEB)) { check type }
and good then
case ptype of
TYPES: doInitLast;
TYPEZ: doEOFLast;
TYPEF: doFile;
TYPEB: doBreak;
end { case }
else
begin
if Debug then
PutCln('Expected File Pack ',STDERR);
SendNAK(n);
end;
end;
end;
end;
procedure RecvSwitch; { this procedure is the main receive routine }
begin
DebugMessage ('RecvSwitch... ');
StartRun;
repeat
case State of
FileData: ReceiveData;
Init: ReceiveInit;
Break: { nothing };
FileHeader: ReceiveFile;
EOFile: { nothing };
Complete: { nothing };
Abort: { nothing };
end;
{ case }
until (State = Abort ) or ( State = Complete );
end;
procedure KermitMain; { Main procedure }
var
aline : string;
j : integer;
errorOccurred : boolean;
begin
DebugMessage ('KermitMain... ');
errorOccurred := false;
case Runtype of
Receive:
begin { filename is optional here }
RecvSwitch;
end;
Transmit:
SendSwitch;
Invalid: { nothing };
end; { case }
FinishUp(errorOccurred); { end of program }
end { main };
{ Include the parser into kermit.(lines 2355-4263) }
{ Determine length of string. }
function LenString(var tempStr : string80) : integer;
var
i : integer;
endofstring : boolean;
begin
i := 80;
endofstring := false;
while ((i >= 1) and not(endofstring)) do
if (tempStr[i] = ' ') then
i := i - 1
else
endofstring := true;
LenString := i;
end;
{ Copy command line into temporary string until either EOS or blank }
procedure SkipBlanks(var command : string80;
var commandLen : integer);
var
i, k, j, oldComLen : integer;
endOfString : boolean;
begin
i := 1;
endofString := false;
oldComLen := commandLen;
while ((i <= commandLen) and (not(endofString))) do
if (command[i] = ' ') then
i := i + 1
else
endofString := true;
k := 1;
for j:=i to commandLen do
begin
command[k] := command[j];
k := k + 1;
end;
if ((oldComLen = 1) and (i <> 1)) then
commandLen := commandLen - i
else
commandLen := commandLen - (i-1);
end;
{ Copy command line into temporary string until either EOS or blank }
procedure CopyToken(var command : string80;
var commandLen : integer;
var tempStr : string13;
var totChars : integer);
const
{ %include 'CURRENT_CONSTANT' (lines 2418-2583}
NULLTOKE = 100;
RANGENULL = 101;
KERMITPROMPT = 'Kermit-CP6>';
KERMITHELP = 'KERMITHLP:';
INVALIDCOMMAND = 1;
INVALIDSETCOMMAND = 2;
INVALIDSHOWCOMMAND = 3;
NOTIMPLEMENTED = 4;
INVALIDFILESPEC = 5;
INVALIDSETCVALUE = 6;
INVALIDSETDVALUE = 7;
INVALIDSETOVALUE = 8;
INVALIDSETRANGE = 9;
SENDPARMS = 10;
RECEIVEPARMS = 11;
LOCALPARMS = 12;
BLANKLINE = 13;
NOHELPAVAILABLE = 14;
IBEXSPAWNFAILED = 15;
cSET = 'SET ';
cSHOW = 'SHOW ';
cSTATUS = 'STATUS ';
cCONNECT = 'CONNECT ';
cHELP = 'HELP ';
cEXIT = 'EXIT ';
cQUIT = 'QUIT ';
cQUESTION = '? ';
cSEND = 'SEND ';
cRECEIVE = 'RECEIVE ';
cDEBUGGING = 'DEBUGGING ';
cLOCALECHO = 'LOCAL-ECHO ';
cDELAY = 'DELAY ';
cPACKETLENGTH = 'PACKET-LENGTH';
cPADDING = 'PADDING ';
cPADCHAR = 'PADCHAR ';
cTIMEOUT = 'TIMEOUT ';
cENDOFLINE = 'END-OF-LINE ';
cQUOTE = 'QUOTE ';
cALL = 'ALL ';
cON = 'ON ';
cOFF = 'OFF ';
cBADTOKEN = 'XX ';
cTRANSMODE = 'TRANSMODE ';
cASCII = 'ASCII ';
cBINARY = 'BINARY ';
cEIGHTQUOTE = 'EIGHT-QUOTE ';
cFILERECORD = 'FILERECORD ';
cCR = 'CR ';
cLF = 'LF ';
cCRLF = 'CRLF ';
cPARITY = 'PARITY ';
cEVEN = 'EVEN ';
cODD = 'ODD ';
cNONE = 'NONE ';
cSPEED = 'SPEED ';
cIBEX = 'IBEX ';
uSET = 3;
uMSEND = 3;
uMRECEIVE = 1;
uSHOW = 2;
uSTATUS = 2;
uCONNECT = 1;
uIBEX = 1;
uHELP = 1;
uQUESTION = 1;
uEXIT = 1;
uQUIT = 1;
uSEND = 1;
uRECEIVE = 1;
uDEBUGGING = 3;
uFILERECORD = 1;
uTRANSMODE = 1;
uLOCALECHO = 2;
uDELAY = 3;
uPACKETLENGTH = 3;
uPADDING = 4;
uPADCHAR = 4;
uTIMEOUT = 1;
uENDOFLINE = 1;
uQUOTE = 1;
uALL = 1;
uON = 2;
uOFF = 2;
uBADTOKEN = 1;
uCR = 2;
uLF = 1;
uCRLF = 2;
uPARITY = 1;
uEVEN = 1;
uODD = 1;
uNONE = 1;
uSPEED = 2;
uASCII = 1;
uBINARY = 1;
uQUOTED = 1;
uEIGHTQUOTE = 1;
oON = 0;
oOFF = 1;
oEVEN = 2;
oODD = 3;
oNONE = 4;
oSET = 5;
oSHOW = 6;
oSTATUS = 7;
oCONNECT = 8;
oHELP = 9;
oEXIT = 10;
oQUIT = 11;
oSEND = 12;
oRECEIVE = 13;
oDEBUGGING = 14;
oLOCALECHO = 15;
oDELAY = 16;
oPACKETLENGTH = 17;
oPADDING = 18;
oPADCHAR = 19;
oTIMEOUT = 20;
oENDOFLINE = 21;
oQUOTE = 22;
oQUESTIONM = 23;
oALL = 24;
oBADTOKEN = 25;
oFILERECORD = 26;
oCR = 27;
oLF = 28;
oCRLF = 29;
oPARITY = 30;
oSPEED = 31;
oIBEX = 32;
oTRANSMODE = 33;
oASCII = 34;
oBINARY = 35;
oEIGHTQUOTE = 36;
oXXXX = 100 ;
oMAINTYPE = 1;
oSETTYPE = 2;
oSHOWTYPE = 3;
oSENDTYPE = 4;
oRECEIVETYPE = 5;
oDEBUGTYPE = 6;
oFILERECTYPE = 8;
oLOCECHOTYPE = 9;
oPARITYTYPE = 10;
oTRANSTYPE = 11;
DECIMAL = 0;
SDECIMAL = 1;
OCTAL = 2;
CHRACTER = 3;
IDECIMAL = 4;
EBCHRACTER = 5;
oASCSTATE = 1;
oBINSTATE = 0;
o300BAUD = 300;
o600BAUD = 600;
o1200BAUD = 1200;
o2400BAUD = 2400;
o4800BAUD = 4800;
o9600BAUD = 9600;
var
i, j, k : integer;
noBlank : boolean;
tempToken : string80;
begin
for i:=1 to SMALLSIZE do
tempStr[i] := ' ';
i := 1;
noblank := true;
while ((i <= commandLen) and (noblank)) do
if (command[i] <> ' ') then
begin
tempToken[i] := command[i];
i := i + 1;
end
else
noBlank := false;
totChars := i - 1;
if (totChars <= SMALLSIZE) then
for i:=1 to totChars do
tempStr[i] := tempToken[i]
else
begin
totChars := 2;
tempStr := cBADTOKEN;
end;
k := 1;
for j:=(totChars+1) to commandLen do
begin
command[k] := command[j];
k := k + 1;
end;
commandLen := commandLen - totChars;
end;
{ Routine to compare strings for symbol comparison. }
function CompareStr(command, symbol : string13;
commandLen, symbolLen : integer) : boolean;
var
i : integer;
sameStr : boolean;
begin
sameStr := true;
i := 1;
while (sameStr and (i <= commandLen)) do
if command[i] <> symbol[i] then
sameStr := false
else
i := i + 1;
i := i - 1;
CompareStr := sameStr and (i >= symbolLen);
end;
procedure StrUpcase(var command : string80;
commandLen : integer);
var
i, diff : integer;
begin
diff := ord('a') - ord('A');
for i:=1 to commandLen do
if ((command[i] >= 'a') and (command[i] <= 'z')) then
command[i] := chr(ord(command[i]) - diff);
end;
function IsNumeric(token : string13;
var tokLen, value : integer;
typeToken : integer) : boolean;
var
goodChar : boolean;
upBound : char;
base, i : integer;
begin
value := 0;
i := 1;
goodChar := true;
upBound := '9';
base := 10;
if (typeToken = OCTAL) then
begin
upBound := '7';
base := 8;
end;
while ((i <= tokLen) and (goodChar)) do
if ((token[i] >= '0') and (token[i] <= upBound)) then
begin
value := (value*base) + (ord(token[i]) - ord('0'));
i := i + 1;
end
else
begin
goodChar := false;
value := 0;
end;
goodChar := goodChar and (tokLen > 0);
if (typeToken = OCTAL) then
IsNumeric := goodChar and ((value >= 0) and (value <= 31))
else
if (typeToken = SDECIMAL) then
IsNumeric := goodChar and ((value >= MINPACKETSIZE) and
(value <= MAXPACKETSIZE))
else
if (typeToken = IDECIMAL) then
IsNumeric := goodChar and ((value = o300BAUD)
or (value=o600BAUD) or (value = o1200BAUD)
or (value=o2400BAUD) or (value = o4800BAUD)
or (value = o9600BAUD))
else
IsNumeric := goodChar and ((value >= 0) and
(value <= 99))
end;
{ Print the ? help message for set menu. }
procedure PrintSetHelp;
begin
writeln;
writeln;
writeln('*** HELP ==>');
writeln;
writeln(' SET keyword');
writeln;
writeln(' Keywords:');
writeln(' SEND