home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
tpdoskermit.tar.gz
/
tpdoskermit.tar
/
kermit.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-18
|
59KB
|
2,208 lines
$R-,S-,I-,D+,T+,F-,V-,B-,N-
$R+,S+,I-,D+,T+,F-,V-,B-,N-
$M $2000,$9000,$18000} {8k STACK, 36k-96k HEAP
PROGRAM Kermits;
Uses MyDos, Crt, Timers, {Keyboard, }Async, Crcs, FeltEdit, FixAttr;
CONST
CpRt : String[40] = 'KERMIT file transfer. V1.1a TMa, NH 1988';
DiskStopInt : BOOLEAN = FALSE;
(**********************************************************************)
(* *)
(* Start for Kermits egne procedures *)
(* *)
(**********************************************************************)
VAR TotalTime, TotalBytes, SendBytes, ReceiveBytes : LongInt;
FileNr : WORD;
$I KERMIT.INC} {Kermit const, type, var and some proc's.
PROCEDURE InitWindow;
VAR i : WORD;
p : Pointer;
BEGIN
FillChar(pw,SizeOf(pw),#0);
ninn := PakkeNr; nut := PakkeNr;
p := Next_Pac;
FOR i := 0 TO 31 DO BEGIN
pw[i].dptr := p;
pw[i+32].dptr := p;
Inc(Word(p),108); {Room for 95 char + fudge factor}
END;
GotoXY(33,10); WriteStr('Window:');
LongPakke := FALSE;
END; { InitWindow }
PROCEDURE Warning(msg : String);
BEGIN
ScrollWin(41,14,80,24,-1,KermitAttr);
GotoXY(27,14); WriteStr('Last warning: '+msg);
END;
TYPE Retry_Code = (r_ok, r_keyboard, r_timeout, r_exit);
VAR r_code : Retry_Code;
FUNCTION Retry : Retry_Code;
VAR ch : CHAR;
code : INTEGER;
enable : BOOLEAN;
BEGIN
r_code := r_ok;
enable := FALSE;
IF KeyPress THEN BEGIN
BIOSKbd(-1,FALSE,ch,code);
IF (ch = #0) THEN
CASE code OF
45 : enable := TRUE;
59 : StopFile := TRUE;
67 : BEGIN
r_code := r_keyboard;
enable := TRUE;
END;
68 : r_code := r_exit;
END;
END
ELSE IF NOT RunningTimer(t2) THEN BEGIN
r_code := r_timeout;
enable := TRUE;
END;
IF enable THEN BEGIN
RS_Enable(CurComPort);
StartLink;
END;
Retry := r_code;
END; {Retry}
PROCEDURE SendLink(VAR buf; n : WORD);
LABEL Ferdig;
VAR d : CharArray ABSOLUTE buf;
i, len : WORD;
ok : BOOLEAN;
ch : CHAR;
dptr : ^CHAR;
BEGIN
Inc(SendBytes,n+2);
i := 10;
IF SendTimeOut > 0 THEN
i := SendTimeOut;
StartTimerSek(t2,i);
IF NOT WindowData THEN BEGIN
WHILE (RS_Buffer[CurComPort].HostXoff OR
NOT RS_Empty(CurComPort)) DO BEGIN
RS_ClrBuffer(CurComPort);
IF Retry <> r_ok THEN GOTO Ferdig;
END;
Delay(PacketDelay); { Wait if neccessary! }
END;
REPEAT
IF Retry <> r_ok THEN GOTO Ferdig;
RS_Write(YourSOH,ok,CurComPort);
UNTIL ok;
IF CurBaud > 30000 THEN Delay(1);
IF IBM_Mode = 1 THEN BEGIN
REPEAT
RS_BusyRead(ch,ok,CurComPort);
IF NOT ok THEN
IF Retry <> r_ok THEN GOTO Ferdig;
UNTIL ok AND (ch = YourSOH);
len := 1;
i := 1;
REPEAT
IF len <= n THEN BEGIN
RS_Write(d[len],ok,CurComPort);
IF ok THEN BEGIN
Inc(len);
Delay(SendDelay);
END;
END;
REPEAT
RS_BusyRead(ch,ok,CurComPort);
IF ok THEN BEGIN
IF (d[i] = ch) OR (d[i] = ' ') THEN
Inc(i);
END
ELSE
IF Retry <> r_ok THEN GOTO Ferdig;
UNTIL (len - i < 40) AND NOT ok;
UNTIL (len > n) AND (i > n);
END
ELSE BEGIN
dptr := Addr(d[1]);
IF CurBaud > 30000 THEN BEGIN
len := MaxPrTick;
REPEAT
IF len > n THEN len := n;
RS_WriteBlock(dptr^,len,i,CurComPort);
Dec(n,len);
Inc(Word(dptr),len);
Delay(1);
UNTIL n = 0;
END
ELSE BEGIN
REPEAT
RS_WriteBlock(dptr^,n,i,CurComPort);
IF Retry <> r_ok THEN GOTO Ferdig;
Dec(n,i);
Inc(Word(dptr),len);
UNTIL n = 0;
END;
END;
REPEAT
RS_Write(YourCR,ok,CurComPort);
UNTIL ok OR (Retry <> r_ok);
Ferdig:
END; { SendLink }
PROCEDURE GetLink(VAR buf; VAR n : WORD; max : WORD);
LABEL Ferdig, Restart_Packet;
VAR d : ARRAY [0..4000] OF CHAR ABSOLUTE buf;
bytes, i, x : WORD;
ch : CHAR;
done : BOOLEAN;
escape : STRING[10];
BEGIN
StartTimerSek(t2,YourTimeOut);
ch := ' ';
REPEAT
RS_BusyRead(ch,done,CurComPort);
IF NOT done THEN
IF Retry <> r_ok THEN GOTO Ferdig;
Inc(ReceiveBytes,Ord(done));
UNTIL (ch=MySOH);
x := 3;
Restart_Packet:
n := 0;
d[0] := '~'; { len = 94 }
d[3] := Chr(LenModulo+31); { plen1 = 94/63 }
d[4] := Chr(LenModulo+31); { plen2 = 94/63 }
REPEAT
RS_ReadBlock(d[n],max - n,bytes,CurComPort);
Inc(ReceiveBytes,bytes);
IF bytes=0 THEN BEGIN
IF d[0] > ' ' THEN BEGIN
IF n > Ord(d[0]) - 32 THEN GOTO Ferdig;
END
ELSE
IF n > (Ord(d[3]) - 32) * LenModulo + Ord(d[4]) - 32 THEN GOTO Ferdig;
IF Retry <> r_ok THEN GOTO Ferdig;
Write_String(d[0],1,1,Byte_Stay,n,KermitAttr);
END
ELSE IF NOT BinaryData AND (d[n] < ' ') THEN BEGIN
IF d[n] = MyCR THEN GOTO Ferdig;
IF d[n] = MySOH THEN BEGIN
GOTO Restart_Packet;
END;
IF (d[n] = ^[) AND (IBM_Mode > 0) THEN BEGIN
escape[0] := #0;
REPEAT { Read an Escape Seq's }
RS_BusyRead(ch,done,CurComPort);
IF NOT done THEN BEGIN
IF Retry <> r_ok THEN GOTO Ferdig;
END
ELSE
escape := escape + ch;
UNTIL done AND (ch IN ['@'..'Z','a'..'z']);
Dec(escape[0]);
IF ch = 'H' THEN BEGIN
WHILE x < 81 DO BEGIN
Inc(x);
d[n] := ' ';
Inc(n);
END;
x := 1;
ch := escape[Length(escape)];
WHILE ch > '1' DO BEGIN
Inc(x);
d[n] := ' ';
Inc(n);
Dec(ch);
END;
END;
END;
{ Ignore other control characters ! }
END
ELSE BEGIN
Inc(n,bytes);
IF IBM_Mode > 0 THEN BEGIN
Inc(x,bytes);
IF x > 81 THEN x := 81;
END;
IF (n >= max) THEN GOTO Ferdig;
END;
UNTIL FALSE;
Ferdig:
END; { GetLink }
FUNCTION CheckSum(VAR buf; n, CheckType : WORD): WORD;
BEGIN
IF CheckType <= 2 THEN BEGIN
n := ChkSum(buf,n);
IF CheckType = 1 THEN
CheckSum := (n + Lo(n) Shr 6) AND 63
ELSE
CheckSum := n AND $FFF;
END
ELSE { CRC }
CheckSum := CRC(buf,n);
END; { CheckSum }
PROCEDURE SendPakkeT(VAR T : PakkeType);
VAR s : WORD;
BEGIN
IF T.long THEN BEGIN
T.plen := ' ';
T.plen1 := Chr(32 + (T.TotLen - 1) DIV LenModulo);
T.plen2 := Chr(32 + ((T.TotLen - 1) MOD LenModulo));
s := CheckSum(T.plen,5,1);
T.hchk := Chr(32 + s);
END
ELSE BEGIN
IF (T.TotLen > 95) OR (T.TotLen < 4) THEN BEGIN
WriteLn('Gal lengde: ',T.TotLen);
Exit;
END;
T.plen := Chr(31 + T.TotLen);
END;
s := CheckSum(T.plen,T.TotLen-CheckType,CheckType);
IF CheckType >= 2 THEN BEGIN
IF CheckType = 3 THEN
T.pdata[T.TotLen-5] := Chr(32 + (s Shr 12));
T.pdata[T.TotLen-4] := Chr(32 + ((s Shr 6) AND 63));
END;
T.pdata[T.TotLen-3] := Chr(32 + (s AND 63));
SendLink(T.plen,T.TotLen);
END; { SendPakkeT }
PROCEDURE SendPakke;
BEGIN
SendPakkeT(TX_Pac^);
END;
PROCEDURE MakePakke(VAR p : PakkeType; nr : CarNum;
typ : PakkeCh; data : String);
BEGIN
p.pnr := Chr(32 + nr);
p.ptype := typ;
p.TotLen := Length(data) + 3 + CheckType;
p.plen := Chr(31 + p.TotLen);
p.long := FALSE;
Move(data[1],p.pdata,Length(data));
END; { MakePakke }
FUNCTION TestPakke(VAR p : PakkeType): BOOLEAN;
VAR chk, c : WORD;
BEGIN
TestPakke := FALSE;
IF p.TotLen <= 2 + CheckType THEN BEGIN
IF p.TotLen > 0 THEN
Warning('Too short packet!')
ELSE IF (p.TotLen = 0) AND ShowTimeOut THEN
Warning('TimeOut!');
Exit;
END;
IF (p.ptype < 'A') OR (p.ptype > 'Z') THEN BEGIN
Warning('Error in packet type!');
Exit;
END;
IF p.plen > ' ' THEN BEGIN
chk := Ord(p.plen) - 32;
p.long := FALSE;
END
ELSE BEGIN
chk := CheckSum(p.plen,5,1);
IF chk <> Ord(p.hchk)-32 THEN BEGIN
Warning('Error in header checksum!');
Exit;
END;
chk := (Ord(p.plen1) - 32) * LenModulo + Ord(p.plen2) - 32;
p.long := TRUE;
END;
IF chk >= p.TotLen THEN BEGIN
Warning('Len error: '+Tstr(chk-p.TotLen-1,1));
Exit;
END;
p.TotLen := Succ(chk);
IF Ord(p.pnr) - 32 > 63 THEN Exit;
chk := CheckSum(p.plen,p.TotLen - CheckType,CheckType);
c := Ord(p.pdata[p.TotLen-3]) - 32;
IF CheckType >= 2 THEN BEGIN
Inc(c,(Ord(p.pdata[p.TotLen-4]) - 32) Shl 6);
IF CheckType = 3 THEN
Inc(c,(Ord(p.pdata[p.TotLen-5]) - 32) Shl 12);
END;
IF c = chk THEN
TestPakke := TRUE
ELSE
Warning('CHK err: Calc='+Tstr(chk,1)+', Rec='+Tstr(c,1));
END; {TestPakke}
PROCEDURE GetFast(VAR p; VAR len : WORD; max : WORD);
LABEL Avbryt;
VAR by : BYTE;
ch : CHAR;
ok : BOOLEAN;
dptr : ^BYTE;
md, dend, bytes, receive, status : WORD;
count : WORD;
BEGIN
StartTimerSek(t2,YourTimeOut);
dptr := Addr(p);
dend := Word(dptr) + max;
receive := RS_Buffer[CurComPort].ICadr;
status := receive + 5;
count := MaxPrTick;
ch := #255;
REPEAT
IF (Retry <> r_ok) OR NOT RunningTimer(t2) THEN GOTO Avbryt;
RS_BusyRead(ch,ok,CurComPort);
Inc(ReceiveBytes,Ord(ok));
UNTIL ch = MySOH;
RS_Set_TX_Int(0,CurComPort);
InLine($FA); {CLI}
Port[receive+1] := 0; {Turn off all Serial int's}
md := 2000; {Wait up to 8 ms for first char.}
REPEAT
repeat
Dec(md);
if md = 0 then goto avbryt;
until Odd(Port[status]); {Received data available}
dptr^ := Port[receive];
Inc(Word(dptr));
md := 200; { >1 ms delay between two chars}
Dec(count);
IF count = 0 THEN BEGIN
InLine($FB);
md := 2000;
count := MaxPrTick;
InLine($FA);
END;
UNTIL Word(dptr) >= dend;
Avbryt:
InLine($FB);
Port[receive+1] := RX_int+RLS_int; {Turn off all Serial int's}
len := Word(dptr) - Ofs(p);
Inc(ReceiveBytes,len);
END;
PROCEDURE GetPakke;
VAR max : WORD;
BEGIN
IF LongPakke THEN max := 9030 ELSE max := 95;
IF (CurBaud > 30000) THEN
GetFast(RX_Pac^.plen,RX_Pac^.TotLen,max)
ELSE
GetLink(RX_Pac^.plen,RX_Pac^.TotLen,max);
IF r_code = r_ok THEN BEGIN
IF NOT TestPakke(RX_Pac^) THEN BEGIN
MakePakke(RX_Pac^,PakkeNr,'T','P');
END;
END
ELSE IF r_code = r_keyboard THEN
MakePakke(RX_Pac^,PakkeNr,'T','K')
ELSE IF r_code = r_timeout THEN
MakePakke(RX_Pac^,PakkeNr,'T','T')
ELSE IF r_code = r_exit THEN
MakePakke(RX_Pac^,PakkeNr,'E','F10')
ELSE BEGIN
Warning('r_code error!');
MakePakke(RX_Pac^,PakkeNr,'T','R');
END;
END; { GetPakke }
PROCEDURE Extract(VAR st : String);
VAR i, l : WORD;
BEGIN
i := 1;
IF RX_Pac^.long THEN i := 4;
l := RX_Pac^.TotLen - i - 2 - CheckType;
IF l >= SizeOf(st) THEN l := SizeOf(st) - 1;
st[0] := Chr(l);
Move(RX_Pac^.pdata[i],st[1],l);
END; { Extract }
PROCEDURE DumpPointers;
CONST NackCh : ARRAY [0..10] OF CHAR = '-123456789A';
VAR n, i : WORD;
BEGIN
st[0] := #31;
FillChar(st[1],31,' ');
n := nut;
FOR i := 1 TO (ninn-nut) AND 63 DO BEGIN
st[i] := NackCh[pw[n].retry];
n := Succ(n) AND 63;
END;
GotoXY(41,10); WriteStr(st);
END;
PROCEDURE MakeInfoScreen(s : String);
BEGIN
ClrAll;
ClrLast;
GotoXY(30,6); WriteStr('File name:');
GotoXY(22,7); WriteStr('Bytes transferred:');
GotoXY(30,9); WriteStr(s);
GotoXY(22,11); WriteStr('Number of packets:');
GotoXY(22,12); WriteStr('Number of retries:');
GotoXY(29,13); WriteStr('Last error:');
GotoXY(1,25); WriteStr('Kermit: F1=Cancel File');
GotoXY(61,MaxY); WriteStr('F9=Retry F10=Abort');
END; { MakeInfoScreen }
PROCEDURE WriteFileName;
BEGIN
GotoXY(41,6);
IF OriginalName <> FileName THEN
WriteStr(Pad(OriginalName + ' as '+FileName,40))
ELSE
WriteStr(Pad(FileName,40));
END;
PROCEDURE WriteBytes;
BEGIN
GotoXY(41,7); Write(Bytes);
END;
PROCEDURE WriteFileSize;
BEGIN
GotoXY(30,8); Write('File size: ',FileMax); ClrEol;
END; { WriteSize }
PROCEDURE WriteStatus;
BEGIN
GotoXY(41,9); WriteStr(StatusString); ClrEol;
END;
PROCEDURE WriteTotalNr;
BEGIN
Inc(TotalNr);
GotoXY(41,11); Write(TotalNr);
END; { WriteTotalNr }
PROCEDURE WriteFeilNr;
BEGIN
Inc(FeilNr); {Auto-Increment FeilNr}
GotoXY(41,12); Write(FeilNr);
END;
PROCEDURE WriteError;
BEGIN
GotoXY(41,13); WriteStr(Pad(ErrorString,57));
RS_ClrBuffer(CurComPort);
END;
PROCEDURE ZeroBytes;
BEGIN
Bytes := 0;
GotoXY(41,7); ClrEol;
END;
PROCEDURE AddBytes(n : WORD);
BEGIN
Bytes := Bytes + n;
WriteBytes;
END; {AddBytes}
PROCEDURE SendPacket(PakkeNr : CarNum; typ : PakkeCh; st : String);
BEGIN
MakePakke(TX_Pac^, pakkenr, typ, st);
SendPakke;
END; { SendPacket }
PROCEDURE SendAbort(s : String);
BEGIN
ErrorString := s;
WriteError;
SendPacket(PakkeNr,'E',s);
END; { SendAbort }
PROCEDURE MakeNextData; FORWARD;
TYPE KermitState = (Abort, Complete, SendInit, SendName,
SendAttr, SendData, SendEOF,
SendEnd, WaitInit, WaitName, WaitData, TimeOut);
PROCEDURE SendAndGet(VAR s : KermitState; OkState : KermitState;
data : BOOLEAN);
VAR Ferdig : BOOLEAN;
nr : WORD;
BEGIN
RetryNr := 0; Ferdig := FALSE;
REPEAT
SendPakke;
IF data THEN
MakeNextData;
GetPakke;
WITH RX_Pac^ DO BEGIN
nr := Ord(pnr) - 32;
IF ((ptype = 'Y') AND (nr = PakkeNr)) OR
((ptype = 'N')) AND (nr = Succ(PakkeNr) AND 63) THEN BEGIN
Ferdig := TRUE;
s := OkState;
PakkeNr := Succ(PakkeNr) AND 63;
WriteTotalNr;
END
ELSE IF (ptype IN ['N','T']) OR (ptype = TX_Pac^.ptype) THEN BEGIN
Inc(RetryNr);
WriteFeilNr;
Warning(ptype+'-packet received!');
IF RetryNr >= RetryLimit THEN BEGIN
Ferdig := TRUE;
s := Abort;
SendAbort('Too many retries!');
END;
END
ELSE IF ptype = 'E' THEN BEGIN
Ferdig := TRUE;
s := Abort;
Extract(ErrorString);
WriteError;
END
ELSE IF (nr = PakkeNr) OR (nr = Succ(PakkeNr) AND 63) THEN BEGIN
SendAbort('Wrong packet type: '+ptype);
ptype := 'E';
Ferdig := TRUE;
s := Abort;
END;
END;
UNTIL Ferdig;
IF s = Abort THEN ErrorLevel := 2;
END; { SendAndGet }
CONST
Reserved1Bit = 32;
Reserved2Bit = 16;
A_PacketBit = 8;
WindowBit = 4;
LongPakkeBit = 2;
BinaryDataBit= 32;
PROCEDURE MakeInitPacket(Ptyp : PakkeCh);
VAR s : String;
b : BYTE;
BEGIN
s := Pad('',14);
IF LongMaxLength < 95 THEN BEGIN
s[1] := Chr(32 + (LongMaxLength));
LongPakke := FALSE;
END
ELSE
s[1] := '~';
IF Ptyp = 'Y' THEN
IF Abs(YourTimeOut-MyTimeOut) < 2 THEN
MyTimeOut := YourTimeOut - 2
ELSE
AttrPakke := TRUE;
s[2] := Chr(32 + (MyTimeOut));
s[3] := Chr(32 + (MyPad));
s[4] := Chr(64 XOR Ord(MyPadChar));
s[5] := Chr(32 + (Ord(MyCR)));
s[6] := MyQCtrlChar;
s[7] := Q8BitChar;
IF (Ptyp = 'S') AND (CurBits=8) THEN
s[7] := 'Y'
ELSE IF (Ptyp = 'Y') AND NOT Q8Bit THEN
s[7] := 'N';
s[8] := Chr(FileCheck+48);
s[9] := QrepChar;
b := A_PacketBit + 1;
IF LongPakke THEN BEGIN
b := b OR LongPakkeBit;
s[13] := Chr(32 + (LongMaxLength DIV LenModulo));
s[14] := Chr(32 + (LongMaxLength MOD LenModulo));
END;
IF WindowData THEN BEGIN
b := b OR WindowBit;
s[12] := Chr(32 + WinSize);
END;
s[10] := Chr(b+32);
b := 0;
IF BinaryData THEN b := BinaryDataBit;
s[11] := Chr(b+32);
MakePakke(TX_Pac^, 0, ptyp, s);
END; { MakeInitPacket }
PROCEDURE TolkInitPacket;
VAR c, l, w, a2 : INTEGER;
s : String;
BEGIN
Extract(s);
s := Pad(s,30);
YourMaxLength := Ord(s[1]) - 32;
IF s[2] > ' ' THEN YourTimeOut := -32 + Ord(s[2]);
IF RX_Pac^.ptype <> 'Y' THEN
IF Abs(YourTimeOut-MyTimeOut) < 2 THEN
MyTimeOut := YourTimeOut - 2;
YourPad := -32 + Ord(s[3]);
YourPadChar := Chr(64 XOR Ord(s[4]));
IF s[5] > ' ' THEN YourCR := Chr(Ord(s[5]) - 32);
IF s[6] > ' ' THEN YourQCtrlChar := s[6];
IF s[7] IN ['!'..'>',#96..'~'] THEN BEGIN
Q8bitChar := s[7];
Q8bit := TRUE;
END
ELSE Q8bit := (s[7] = 'Y') AND (CurBits=7);
CASE s[8] OF
'2' : FileCheck := 2;
'3' : FileCheck := 3;
ELSE
FileCheck := 1;
END;
Qrep := s[9] = QrepChar;
IF Qrep THEN maxrep := 94 ELSE maxrep := 1;
c := Ord(s[10]) - 32;
a2 := 0;
IF Odd(c) THEN a2 := Ord(s[11]) - 32;
l := 10;
WHILE Odd(Ord(s[l])) DO Inc(l); {skip all other attribute bits}
WindowData := WindowData AND (c AND WindowBit <> 0);
IF WindowData THEN BEGIN
WinSize := Ord(s[l+1]) - 32; {We can accept any size up to 31}
WindowData := WinSize > 1;
END;
LongPakke := LongPakke AND (c AND LongPakkeBit <> 0) AND NOT WindowData;
AttrPakke := AttrPakke AND (c AND A_PacketBit <> 0);
IF LongPakke THEN BEGIN
l := (Ord(s[l+2]) - 32) * LenModulo + Ord(s[l+3]) - 32;
IF l = 0 THEN
LongMaxLength := 500
ELSE IF l < LongMaxLength THEN
LongMaxLength := l;
END;
BinaryData := BinaryData AND (a2 AND BinaryDataBit <> 0);
END; {TolkInitPacket}
PROCEDURE XmitAttr(VAR state : KermitState);
VAR siz : String[12];
BEGIN
UnPackTime(DTA.Time,FTime);
Str((FileMax + 1023) DIV 1024:1,st);
Str(FileMax:1,siz);
st := '#/861124 14:56:30!'+Chr(32+Length(st))+
st+'1'+Chr(32+Length(siz))+siz;
ByteToDigits(FTime.year MOD 100,st[3]);
ByteToDigits(FTime.month,st[5]);
ByteToDigits(FTime.day,st[7]);
ByteToDigits(FTime.hour,st[10]);
ByteToDigits(FTime.min,st[13]);
ByteToDigits(FTime.sec,st[16]);
MakePakke(TX_Pac^, PakkeNr,'A',st);
SendAndGet(state,SendData,FALSE);
IF (state = SendData) THEN BEGIN
Extract(st);
IF (Length(st) > 0) AND (st[1] = 'N') THEN BEGIN
StopFile := TRUE;
state := SendEOF;
END;
END;
END;
PROCEDURE XmitEOF(VAR s : KermitState);
BEGIN
Inc(TotalBytes,FilePos(fil));
Close(fil);
Debug('Enter XmitEOF');
IF StopFile THEN BEGIN
MakePakke(TX_Pac^, PakkeNr,'Z','D');
Warning(FileName+' discarded!');
END
ELSE
MakePakke(TX_Pac^, PakkeNr,'Z','');
SendAndGet(s,SendName,FALSE);
END; { XmitEOF }
PROCEDURE XmitEnd(VAR s : KermitState);
BEGIN
MakePakke(TX_Pac^, PakkeNr,'B','');
SendAndGet(s,Complete,FALSE);
END; { XmitEnd }
TYPE STRING3 = RECORD
CASE BOOLEAN OF
FALSE: (st : STRING[3]);
TRUE: (p : Pointer);
END;
VAR CodeTab : ARRAY [CHAR] OF STRING3;
PROCEDURE MakeCodeTab;
TYPE Str3Ptr = ^String3;
VAR lch, ch : CHAR;
b : WORD;
CodePtr : Str3Ptr;
st : ARRAY [0..3] OF CHAR;
len : BYTE ABSOLUTE st;
BEGIN
CodePtr := @CodeTab;
FOR b := 0 TO 255 DO BEGIN
ch := Chr(b);
lch := Chr(b AND 127);
len := 0;
IF (ch > #127) AND Q8Bit THEN BEGIN
len := 1;
st[1] := Q8BitChar;
ch := lch;
END;
IF (Succ(b) AND 127) <= 32 THEN BEGIN
Inc(len);
st[len] := YourQCtrlChar;
ch := Chr(64 XOR Ord(ch));
END
ELSE IF ((lch = Q8BitChar) AND Q8Bit) OR ((lch = QrepChar) AND Qrep) OR
(lch = YourQCtrlChar) THEN BEGIN
Inc(len);
st[len] := YourQCtrlChar;
END;
Inc(len);
st[len] := ch;
CodePtr^ := String3(st);
Inc(Word(CodePtr),SizeOf(String3));
END;
END; {MakeCodeTab}
PROCEDURE MakeDataPac(VAR p : PakkeType);
LABEL Avbryt;
VAR ch : CHAR;
st : STRING[3];
pst : Pointer ABSOLUTE st;
n, max, databytes : WORD;
dptr : ^CHAR;
BEGIN
p.ptype := 'D';
p.pnr := Chr(32 + PakkeNr);
dptr := @p.pdata[1];
IF LongPakke THEN BEGIN
Inc(Word(dptr),3); {Skip over long header}
max := LongMaxLength - 7 - CheckType;
p.long := TRUE;
END
ELSE BEGIN
max := YourMaxLength - 7 - CheckType;
p.long := FALSE;
END;
databytes := 0;
IF EndOfFile THEN GOTO Avbryt;
IF BinaryData THEN BEGIN
Inc(max,4);
IF BufCount < max THEN BEGIN
IF BufCount > 0 THEN BEGIN
Move(BufPtr^,dptr^,BufCount);
Inc(Word(dptr),BufCount);
Inc(databytes,BufCount);
Dec(max,BufCount);
END;
BlockRead(fil,buffer^,BufSize,BufCount);
IF (IOresult <> 0) OR (BufCount = 0) THEN BEGIN
EndOfFile := TRUE;
GOTO Avbryt;
END;
BufferPtr(BufPtr) := Buffer;
IF max > BufCount THEN max := BufCount;
END;
Move(BufPtr^,dptr^,max);
Inc(Word(BufPtr),max);
Dec(BufCount,max);
Inc(Word(dptr),max);
Inc(databytes,max);
GOTO Avbryt;
END;
max := Ofs(p.pdata[max]);
REPEAT
IF BufCount = 0 THEN BEGIN
StopLink;
BlockRead(fil,buffer^,BufSize,BufCount);
StartLink;
IF (IOresult <> 0) OR (BufCount = 0 ) THEN BEGIN
EndOfFile := TRUE;
GOTO AvBryt;
END;
BufferPtr(BufPtr) := Buffer;
buffer^[BufCount] := Chr(NOT Ord(buffer^[BufCount - 1])); {guard!}
END;
ch := BufPtr^;
n := 1;
Inc(Word(BufPtr));
Dec(BufCount);
WHILE (ch = BufPtr^) AND (n < MaxRep) DO BEGIN
Inc(n);
Inc(Word(BufPtr));
Dec(BufCount);
END;
IF TextFile THEN BEGIN
ch := UtConvert[ch];
IF ch = ^Z THEN BEGIN
EndOfFile := TRUE;
Goto Avbryt;
END;
END;
Inc(databytes,n);
pst := CodeTab[ch].p; {st := CodeTab[ch].st;}
IF (n = 2) AND (st[0] = #1) THEN BEGIN
dptr^ := st[1];
Inc(Word(dptr));
dptr^ := st[1]; {repeat 2 times!}
Inc(Word(dptr));
END
ELSE BEGIN
IF n >= 2 THEN BEGIN
dptr^ := QrepChar;
Inc(Word(dptr));
dptr^ := Chr(n+32);
Inc(WORD(dptr));
END;
dptr^ := st[1];
Inc(WORD(dptr));
IF st[0] > #1 THEN BEGIN
dptr^ := st[2];
Inc(WORD(dptr));
IF st[0] > #2 THEN BEGIN
dptr^ := st[3];
Inc(WORD(dptr));
END;
END;
END;
UNTIL Word(dptr) >= max;
Avbryt:
IF databytes = 0 THEN
p.TotLen := 0
ELSE BEGIN
AddBytes(databytes);
p.TotLen := Word(dptr) - Ofs(p.plen) + CheckType;
END;
END; {MakeDataPac}
PROCEDURE MakeNextData;
BEGIN
IF NOT Next_Data_OK AND (CurBaud < 30000) THEN BEGIN
MakeDataPac(Next_Pac^);
Next_Data_OK := TRUE;
END;
END;
PROCEDURE MakeData;
VAR temp : PakkeTypePtr;
BEGIN
IF Next_Data_OK THEN BEGIN
temp := TX_Pac;
TX_Pac := Next_Pac;
Next_Pac := temp;
TX_Pac^.pnr := Chr(32 + PakkeNr);
Next_Data_OK := FALSE;
END
ELSE
MakeDataPac(TX_Pac^);
END; { MakeData }
PROCEDURE Ack(PakkeNr : WORD);
BEGIN
SendPacket(PakkeNr,'Y','');
END;
PROCEDURE Nack(PakkeNr : WORD);
BEGIN
SendPacket(PakkeNr,'N','');
END;
VAR state : KermitState;
NackedNr : WORD;
RX_Start : BOOLEAN;
PROCEDURE InitLesPakke;
BEGIN
StartTimerSek(t2,YourTimeOut);
RX_Start := TRUE;
END;
PROCEDURE LesPakke(VAR RX: PakkeType; VAR ok : BOOLEAN);
LABEL Ferdig, Init;
VAR bytes, n : WORD;
buf : ARRAY [-3..100] OF CHAR ABSOLUTE RX;
BEGIN
ok := FALSE;
WITH RX DO BEGIN
IF Retry <> r_ok THEN BEGIN
IF r_code = r_timeout THEN
MakePakke(RX,nut,'T','T')
ELSE IF r_code = r_keyboard THEN
MakePakke(RX,nut,'T','K')
ELSE
MakePakke(RX,nut,'E','F10');
ok := TRUE;
GOTO Init;
END;
IF RX_Start THEN BEGIN
n := 100;
REPEAT
Dec(n);
IF n = 0 THEN Exit;
RS_ReadBlock(plen,96,bytes,CurComPort);
IF bytes = 0 THEN Exit;
Inc(ReceiveBytes,bytes);
UNTIL plen = MySOH;
RX_Start := FALSE;
TotLen := 0;
plen := '~';
END;
REPEAT
RS_ReadBlock(buf[TotLen],96-TotLen,bytes,CurComPort);
IF bytes = 0 THEN BEGIN
IF TotLen > Ord(plen) - 32 THEN GOTO Ferdig;
Exit;
END;
Inc(ReceiveBytes,bytes);
IF NOT BinaryData AND (buf[TotLen] < ' ') THEN BEGIN
IF buf[TotLen] = MyCR THEN GOTO Ferdig;
IF buf[TotLen] = MySOH THEN BEGIN
TotLen := 0;
plen := '~';
END;
Exit;
END;
Inc(TotLen,bytes);
UNTIL TotLen > 100;
Ferdig:
ok := TestPakke(RX) AND (TotLen < 96) AND NOT RX.long;
$IFDEF DEBUG
IF LogFileMode = LogAll THEN BEGIN
LogChar('<');
FOR n := 0 TO Pred(TotLen) DO
LogChar(buf[n]);
LogChar('>');
END;
$ENDIF
Init:
InitLesPakke;
END;
END; {LesPakke}
PROCEDURE TrySend;
BEGIN
IF RS_Room(CurComPort) < 4000 THEN Exit; { >1 packet already in pipeline}
IF NackedNr = 0 THEN BEGIN
IF (ninn-nut) AND 63 < WinSize THEN BEGIN
IF EndOfFile THEN BEGIN
{ IF nut = ninn THEN
Debug('File completed'); }
Exit; {No more Data packets}
END;
PakkeNr := ninn;
WITH pw[ninn] DO BEGIN
MakeDataPac(dptr^);
IF dptr^.TotLen > 0 THEN BEGIN
SendPakkeT(dptr^);
acknack := 0; {acked := FALSE; nacked := FALSE;}
retry := 0;
ninn := Succ(ninn) AND 63;
END;
END;
Exit;
END;
{Window is full, see if any acked}
IF pw[nut].retry > 0 THEN Exit;
n := nut;
REPEAT
n := Succ(n) AND 63;
IF n = ninn THEN Exit;
UNTIL pw[n].acknack <> 0;
SendPakkeT(pw[nut].dptr^);
pw[nut].retry := 1;
Exit;
END
ELSE BEGIN {NackedNr > 0}
n := nut;
Dec(NackedNr);
WHILE NOT pw[n].nacked DO BEGIN
n := Succ(n) AND 63;
IF n = ninn THEN BEGIN
Warning('No NACK');
Exit;
END;
END;
SendPakkeT(pw[n].dptr^);
pw[n].nacked := FALSE;
END;
END; {TrySend}
PROCEDURE DoPakke;
VAR msg : String;
BEGIN
WITH RX_Pac^ DO BEGIN
IF EndOfFile THEN Debug('EOF - '+Tstr((ninn-nut) AND 63,1));
WriteTotalNr;
nr := -32 +Ord(pnr); {Position in circular buffer}
n := (nr - nut) AND 63; {Offset from first packet}
Extract(msg);
IF ptype = 'T' THEN BEGIN
RS_Enable(CurComPort);
WriteFeilNr;
WITH pw[nut] DO BEGIN
IF NOT nacked THEN BEGIN
Inc(NackedNr);
nacked := TRUE;
END;
END;
Inc(RetryNr);
IF RetryNr > 10 THEN BEGIN
SendAbort('Too many retries!');
state := Abort;
END;
Exit;
END;
RetryNr := 0;
IF ptype = 'Y' THEN BEGIN
IF msg = 'X' THEN BEGIN
StopFile := TRUE;
state := SendEOF;
END;
IF n >= (ninn-nut) AND 63 THEN BEGIN
Debug('ACK outside');
Exit; {ACK outside of window}
END;
WITH pw[nr] DO BEGIN
acked := TRUE;
IF nacked THEN BEGIN
Dec(NackedNr);
nacked := FALSE;
END;
END;
WHILE pw[nut].acked DO BEGIN
nut := Succ(nut) AND 63;
IF ninn = nut THEN BEGIN
IF EndOfFile THEN BEGIN
state := SendEOF;
Debug('Exit TrySend');
END;
Exit;
END;
END;
Exit;
END;
IF ptype = 'N' THEN BEGIN
RS_Enable(CurComPort);
IF n >= (ninn-nut) AND 63 THEN BEGIN {NACK outside window}
Debug('NACK outside');
IF nut = ninn THEN BEGIN
Debug('Window empty');
Exit;
END;
nr := nut
END;
WriteFeilNr;
WITH pw[nr] DO BEGIN
Inc(retry);
IF retry > 10 THEN BEGIN
SendAbort('Too many retries!');
state := Abort;
Exit;
END;
NackedNr := Succ(NackedNr) - Ord(nacked);
nacked := TRUE;
END;
Exit;
END;
IF ptype = 'E' THEN BEGIN
Extract(ErrorString);
IF ErrorString <> 'F10' THEN
WriteError;
state := Abort;
Exit;
END;
SendAbort('Unexpected packet type: '+ptype);
state := Abort;
END;
END;
PROCEDURE SendWindow;
VAR done : BOOLEAN;
i : WORD;
BEGIN
NackedNr := 0;
InitLesPakke;
InitWindow;
REPEAT
TrySend;
FOR i := 1 TO 4 DO BEGIN
LesPakke(RX_Pac^,done); {Bad packet will be ignored}
IF done THEN DoPakke;
END;
DumpPointers;
IF StopFile AND (state<>Abort) THEN state := SendEOF;
UNTIL state IN [SendEOF,Abort];
{
IF state = SendEOF THEN
Debug('Exit SendEOF')
ELSE
Debug('Exit Abort');
}
PakkeNr := ninn;
END;
PROCEDURE SendManyFiles(FilePattern : String);
VAR ok, server : BOOLEAN;
po : INTEGER;
fn : String;
BEGIN
server := FilePattern <> '';
IF NOT server THEN BEGIN
ReadFileName('File(s) to send: ',FilePattern);
IF FilePattern = '' THEN Exit;
END;
IF Pos('.',FilePattern) = 0 THEN
FilePattern := FilePattern + '.';
FindFirst(FilePattern,0,DTA);
ok := DosError = 0;
IF NOT ok THEN BEGIN
Error('No files found!');
Exit;
END;
FileName := DTA.Name;
po := Ord(FilePattern[0]);
WHILE po > 0 DO BEGIN
IF FilePattern[po] IN ['\',':'] THEN BEGIN
Delete(FilePattern,po+1,30);
po := 0;
END;
Dec(po);
END;
IF po = 0 THEN FilePattern[0] := #0;
state := SendInit;
ShowTimeOut := TRUE;
PakkeNr := 0;
FeilNr := 0;
TotalNr := 0;
LastNr := 63;
MakeInfoScreen(' Sending:');
StatusString := 'Init';
WriteStatus;
InitStat;
RS_ClrBuffer(CurComPort);
REPEAT
CASE state OF
SendData : BEGIN
IF WindowData THEN SendWindow
ELSE BEGIN
MakeData;
IF StopFile OR (TX_Pac^.TotLen = 0) THEN
state := SendEOF
ELSE BEGIN
SendAndGet(state,SendData,TRUE);
IF state=Abort THEN BEGIN
Close(fil);
END
ELSE IF (RX_Pac^.TotLen > 4) AND
(RX_Pac^.pdata[1] = 'X') THEN BEGIN
StopFile := TRUE;
state := SendEOF;
END;
END;
END;
END;
SendInit : BEGIN
MakeInitPacket('S');
SendAndGet(state,SendName,FALSE);
IF state=SendName THEN BEGIN
TolkInitPacket;
MakeCodeTab;
CheckType := FileCheck;
END;
END;
SendName : BEGIN
fn := FilePattern + FileName + #0;
OriginalName := FileName;
Assign(fil,fn);
Reset(fil,1);
Next_Data_OK := FALSE;
IF IOresult = 0 THEN BEGIN
WriteFileName;
FileMax := FileSize(fil);
WriteFileSize;
Inc(FileNr);
MakePakke(TX_Pac^, PakkeNr,'F',FileName);
SendAndGet(state,SendData,FALSE);
IF state=SendData THEN BEGIN
BufCount := 0;
BufferPtr(BufPtr) := Buffer;
EndOfFile := FALSE;
ZeroBytes;
StatusString := 'In Progress';
WriteStatus;
StopFile := FALSE;
IF AttrPakke THEN state := SendAttr;
END;
END
ELSE BEGIN
Error('File not found: '+fn);
state := Abort;
END;
END;
SendAttr : BEGIN
XmitAttr(state);
IF state = Abort THEN
Close(fil)
END;
SendEOF : BEGIN
XmitEOF (state);
IF state <> Abort THEN BEGIN
FindNext(DTA);
ok := DosError = 0;
IF ok THEN BEGIN
state := SendName;
FileName := DTA.Name;
END
ELSE
state := SendEnd;
END;
END;
SendEnd : BEGIN
XmitEnd(state);
StatusString := 'Completed!';
WriteStatus;
END;
Abort : BEGIN
StatusString := 'Aborted';
WriteStatus;
SendAbort('Too many retries!');
Close(fil);
ErrorLevel := 3;
END;
END;
UNTIL state IN [Complete,Abort];
Bell;
ShowStat;
END; { SendManyFiles }
TYPE PakkeChar = 'A'..'Z';
PakkeSet = SET OF PakkeChar;
ReceiveType = (RecF, GetF, ServF, TextF);
VAR Ferdig, CheckSkip, ValidDate : BOOLEAN;
Expect : PakkeSet;
PROCEDURE TestDate;
VAR old : FILE;
newTime, oldTime : LongInt;
BEGIN
IF OriginalName <> FileName THEN BEGIN
Assign(old,OriginalName); Reset(old,1);
GetFTime(old,oldTime);
Close(old);
PackTime(FTime,newTime);
IF ((newTime > oldTime) AND (NewDupHandle = SkipFile)) OR
((newTime <= oldTime) AND (OldDupHandle = SkipFile)) THEN
StopFile := TRUE;
END;
CheckSkip := TRUE;
IF IOresult <> 0 THEN WriteStr('Test Error'^G);
END;
PROCEDURE GetFileAttr;
VAR l, st : String;
p, feil, len : INTEGER;
BEGIN
Extract(st);
WHILE st[0] >= #3 DO BEGIN
len := Ord(st[2]) - 32;
l := Copy(st,3,len);
CASE st[1] OF
'!' : BEGIN GotoXY(30,8); WriteStr('File size: '+Pad(l+'k',10)); END;
'1' : BEGIN GotoXY(30,8); WriteStr('File size: '+Pad(l,10)); END;
'#' : BEGIN
p := Pos(' ',l);
Val(Copy(l,p-6,2),FTime.year,feil);
Inc(FTime.year,1900);
IF feil = 0 THEN Val(Copy(l,p-4,2),FTime.month,feil);
IF feil = 0 THEN Val(Copy(l,p-2,2),FTime.day,feil);
IF feil = 0 THEN Val(Copy(l,p+1,2),FTime.hour,feil);
IF feil = 0 THEN Val(Copy(l,p+4,2),FTime.min,feil);
IF (feil = 0) AND (Ord(l[0]) >= p + 8) THEN
Val(Copy(l,p+7,2),FTime.sec,feil);
IF feil = 0 THEN BEGIN
ValidDate := TRUE;
TestDate;
END;
END;
END;
Delete(st,1,len+2);
END;
END;
PROCEDURE SetFileDate;
VAR t : LongInt;
BEGIN
IF NOT ValidDate THEN Exit;
PackTime(FTime,t);
SetFTime(fil,t);
END;
VAR CtrlTab : ARRAY [CHAR] OF CHAR;
PROCEDURE MakeCtrlTab;
VAR ch : CHAR;
BEGIN
FOR ch := #0 TO #255 DO CtrlTab[ch] := ch;
FOR ch := #$3F TO #$5F DO CtrlTab[ch] := Chr(Ord(ch) XOR 64);
FOR ch := #$BF TO #$DF DO CtrlTab[ch] := Chr(Ord(ch) XOR 64);
END;
PROCEDURE DecodeData(VAR p : PakkeType);
VAR n, mask : BYTE;
ch : CHAR;
dptr : ^CHAR;
dlen, max, databytes : WORD;
BEGIN
IF DiskError THEN Exit;
max := 1;
IF p.long THEN max := 4;
dptr := Addr(p.pdata[max]);
max := Ofs(p.pdata[p.TotLen - 2 - CheckType]);
databytes := 0;
IF BinaryData THEN BEGIN
dlen := max - Word(dptr);
IF BufCount < dlen THEN BEGIN
Move(dptr^,BufPtr^,BufCount);
BlockWrite(fil,buffer^,BufSize);
IF IOresult <> 0 THEN BEGIN
DiskError := TRUE;
Exit;
END;
Inc(Word(dptr),BufCount);
AddBytes(BufCount);
Dec(dlen,BufCount);
BufferPtr(BufPtr) := Buffer;
BufCount := BufSize;
END;
Move(dptr^,BufPtr^,dlen);
Inc(Word(BufPtr),dlen);
Dec(BufCount,dlen);
AddBytes(dlen);
Exit;
END;
REPEAT
ch := dptr^; Inc(WORD(dptr));
n := 1;
IF ch = RepQ THEN BEGIN
n := BYTE(dptr^) - 32; Inc(WORD(dptr));
ch := dptr^; Inc(WORD(dptr));
END;
mask := 0;
IF ch = Bit8Q THEN BEGIN
mask := $80;
ch := dptr^; Inc(WORD(dptr));
END;
IF ch = YourQCtrlChar THEN BEGIN
ch := CtrlTab[dptr^]; Inc(WORD(dptr));
END;
ch := CHAR(BYTE(ch) OR mask);
IF TextFile THEN ch := InnConvert[ch];
Inc(databytes,n);
REPEAT
BufPtr^ := ch;
Inc(Word(BufPtr));
Dec(BufCount);
IF BufCount = 0 THEN BEGIN
StopLink;
BlockWrite(fil,buffer^,BufSize);
StartLink;
BufferPtr(BufPtr) := Buffer;
BufCount := BufSize;
IF IOresult <> 0 THEN BEGIN
DiskError := TRUE;
Exit;
END;
END;
Dec(n);
UNTIL n = 0;
UNTIL WORD(dptr) >= max;
AddBytes(databytes);
END; {DecodeData}
PROCEDURE EOF_Packet;
VAR EraseFile : BOOLEAN;
old, bak : FILE;
Bak_file : String[64];
punkt : INTEGER;
oldTime, newTime : LongInt;
BEGIN
Extract(st);
IF BufCount < BufSize THEN BlockWrite(fil,Buffer^,BufSize-BufCount);
SetFileDate;
Inc(TotalBytes,FilePos(fil));
Close(fil);
IF (st = 'D') OR StopFile THEN BEGIN
Erase(fil);
Warning(Filename+' skipped!');
END
ELSE BEGIN
IF OriginalName <> FileName THEN BEGIN
Assign(old,OriginalName); Reset(old,1);
IF ValidDate THEN BEGIN
GetFTime(old,oldTime);
PackTime(FTime,newTime);
EraseFile := ((newTime>oldTime) AND (NewDupHandle=OverWriteFile)) OR
((newTime<=oldTime) AND (OldDupHandle=OverWriteFile));
END
ELSE BEGIN
EraseFile := DupHandle = OverWriteFile;
END;
Close(old);
IF EraseFile THEN BEGIN
punkt := Pos('.',OriginalName);
IF punkt = 0 THEN punkt := Length(OriginalName)+1;
BAK_file := Copy(OriginalName,1,punkt-1) + '.BAK';
IF (OriginalName <> BAK_File) THEN BEGIN
IF Exist(BAK_File) THEN BEGIN
Assign(bak,BAK_File);
Erase(bak);
END;
Rename(old,BAK_File);
Rename(fil,OriginalName);
Warning(FileName+' renamed to '+OriginalName);
END;
END;
END;
END;
IF IOresult=0 THEN
Ack(PakkeNr)
ELSE BEGIN
SendAbort('File close error!');
Ferdig := TRUE;
END;
Expect := ['B','F'];
StatusString := 'File Closed';
WriteStatus;
END;
PROCEDURE TestPacketNr(VAR ok : BOOLEAN);
VAR i, j : WORD;
BEGIN
ok := FALSE;
n := (nr - nut) AND 63;
IF n < (ninn-nut) AND 63 THEN BEGIN
ok := n < WinSize; {Retransmitted packet}
Exit;
END;
i := (nr - ninn) AND 63; {Packets past last}
IF i >= WinSize THEN Exit; {Outside of max send window}
FOR j := 0 TO i DO BEGIN
IF (ninn-nut) AND 63 = WinSize THEN BEGIN
IF NOT pw[nut].acked THEN BEGIN
SendAbort('Window overflow!');
ferdig := TRUE;
Exit;
END;
DecodeData(pw[nut].dptr^);
nut := Succ(nut) AND 63;
END;
WITH pw[ninn] DO BEGIN
retry := 0;
acked := FALSE;
IF j < i THEN BEGIN
Nack(ninn);
retry := 1;
END;
END;
ninn := Succ(ninn) AND 63;
END;
ok := TRUE;
END; { TestPacketNr }
PROCEDURE WindowReceive;
VAR ok : BOOLEAN;
BEGIN { RX_Pac has the first data packet }
InitWindow;
REPEAT
DumpPointers;
WITH RX_Pac^ DO BEGIN
nr := -32 +Ord(pnr);
CASE ptype OF
'T' : BEGIN
Inc(RetryNr);
WriteFeilNr;
IF RetryNr > 10 THEN BEGIN
SendAbort('Too many timeouts!');
Ferdig := TRUE;
Exit;
END;
n := nut;
WHILE pw[n].acked AND (n <> ninn) DO n := Succ(n) AND 63;
IF (n <> ninn) OR (pdata[1] <> 'P') THEN
Nack(n); { Most wanted packet nr! }
RS_Enable(CurComPort);
END;
'E' : BEGIN
Extract(ErrorString);
IF ErrorString <> 'F10' THEN WriteError;
IF ErrorLevel < 2 THEN ErrorLevel := 2;
Ferdig := TRUE;
Exit;
END
ELSE BEGIN
RetryNr := 0;
IF ptype = 'Z' THEN BEGIN
Extract(st);
IF st <> 'D' THEN BEGIN
WHILE nut <> ninn DO BEGIN
IF NOT pw[nut].acked THEN BEGIN
SendAbort('No ACK at EOF:'+pnr);
Ferdig := TRUE;
Exit;
END;
DecodeData(pw[nut].dptr^);
nut := Succ(nut) AND 63;
DumpPointers;
END;
END;
PakkeNr := nr;
EOF_Packet;
Exit;
END;
IF StopFile THEN
SendPacket(nr,'Y','X')
ELSE IF DiskError THEN BEGIN
SendAbort('File write error!');
ferdig := TRUE;
Exit;
END
ELSE BEGIN
TestPacketNr(ok); {Sjekk om nr i vindu, sett n}
IF ferdig THEN Exit;
IF ok THEN WITH pw[nr] DO BEGIN
IF ptype = 'D' THEN BEGIN
IF NOT acked THEN BEGIN
Move(RX_Pac^,dptr^,100);{Room for overhead}
acked := TRUE;
END
ELSE BEGIN
Inc(retry);
IF retry > 10 THEN BEGIN
SendAbort('Too many retries!');
ferdig := TRUE;
Exit;
END;
END;
Ack(nr);
END
ELSE BEGIN
SendAbort('Unexpected packet type: '+ptype);
Ferdig := TRUE;
Exit;
END;
END
ELSE BEGIN
WriteFeilNr;
END
END;
END; {ELSE BEGIN}
END; {CASE ptype OF}
GetPakke;
WriteTotalNr;
END; {WITH RX_Pac^ DO}
UNTIL FALSE;
END; { WindowReceive }
PROCEDURE ReceiveFiles(GetFile : ReceiveType; GetName : String);
VAR LastPk : PakkeCh;
state : KermitState;
l, n : INTEGER;
ch : CHAR;
MainName, Ext, Path, st : String;
ok, done : BOOLEAN;
BEGIN
IF (GetFile=GetF) AND (GetName = '') THEN BEGIN
ReadFileName('File(s) to Get: ',GetName);
IF GetName[0]=#0 THEN Exit;
END;
RS_ClrBuffer(CurComPort);
Expect := ['S'];
LastPk := '@';
PakkeNr := 0;
TotalNr := 0;
FeilNr := 0;
LastNr := 63;
RetryNr := 0;
Ferdig := FALSE;
ShowTimeOut := TRUE;
MakeInfoScreen('Receiving:');
FileName[0] := #0;
ErrorString[0] := #0;
StatusString := 'Init';
WriteStatus;
RS_ClrBuffer(CurComPort);
DiskError := FALSE;
IF GetFile=GetF THEN BEGIN
MakeInitPacket('I');
SendAndGet(state,Complete,FALSE);
IF state=Complete THEN
TolkInitPacket;
SendPacket(0,'R',GetName);
END;
PakkeNr := 0;
IF GetFile<>ServF THEN
GetPakke;
InitStat;
REPEAT
WITH RX_Pac^ DO BEGIN
IF ptype = 'T' THEN BEGIN
Inc(RetryNr);
IF RetryNr <= RetryLimit THEN BEGIN
WriteFeilNr;
Nack(PakkeNr);
END
ELSE BEGIN
SendAbort('Too many retries!');
Ferdig := TRUE;
ErrorLevel := 1;
END;
END
ELSE BEGIN
RetryNr := 0;
IF (pnr = Chr(32 + PakkeNr)) AND (ptype IN Expect) THEN BEGIN
CASE ptype OF
'D' :
BEGIN
IF NOT CheckSkip THEN BEGIN
IF OriginalName <> FileName THEN
StopFile := DupHandle = SkipFile;
CheckSkip := TRUE;
END;
IF WindowData THEN
WindowReceive
ELSE IF StopFile THEN
SendPacket(PakkeNr,'Y','X')
ELSE IF DiskError THEN
SendAbort('File write error!')
ELSE BEGIN
IF NOT DiskStopInt THEN Ack(PakkeNr);
Expect := ['D','Z'];
DecodeData(RX_Pac^);
IF DiskStopInt THEN Ack(PakkeNr);
END;
END;
'S' : BEGIN
TolkInitPacket;
RepQ := #0;
IF Qrep THEN RepQ := QrepChar;
Bit8Q := #0;
IF Q8bit THEN Bit8Q := Q8bitChar;
MakeInitPacket('Y');
SendPakke;
CheckType := FileCheck;
IF GetFile = TextF THEN
Expect := ['X']
ELSE
Expect := ['F'];
StatusString := 'GetFileName';
WriteStatus;
MakeCtrlTab;
END;
'X' :
BEGIN
FileName := 'CON'; OriginalName := FileName;
Assign(fil,'KERMIT.$$$');
ReWrite(fil,1);
IF IOresult<>0 THEN BEGIN
SendAbort('Cannot Create File!');
Ferdig := TRUE;
END
ELSE BEGIN
CheckSkip := FALSE;
ValidDate := FALSE;
BufferPtr(BufPtr) := Buffer;
BufCount := BufSize;
Expect := ['A','D','Z'];
StatusString := 'In progress';
WriteStatus;
WriteFileName;
ZeroBytes;
StopFile := FALSE;
Ack(PakkeNr);
LongReply := TRUE;
END;
END;
'F' :
BEGIN
Inc(FileNr);
Extract(FileName);
FOR l := 1 TO Ord(FileName[0]) DO
IF NOT (FileName[l] IN FileNameSet) THEN
FileName[l] := 'X';
Ext := '.';
MainName[0] := #0;
Path[0] := #0;
IF Pos(':',FileName) = 2 THEN BEGIN
Path := Copy(FileName,1,2);
IF NOT (Path[1] IN ['A'..'Z']) THEN Path[0] := #0;
Delete(FileName,1,2);
END;
l := Ord(FileName[0]);
WHILE l > 0 DO BEGIN
IF FileName[l] = '.' THEN BEGIN
IF Ext = '.' THEN BEGIN
Ext := Copy(FileName,l,4);
FileName := Copy(FileName,1,Pred(l));
END
ELSE
FileName[l] := 'X';
END
ELSE IF FileName[l] = '\' THEN BEGIN
Path := Path + Copy(FileName,1,l);
Delete(FileName,1,l);
l := 0;
END
ELSE IF FileName[l] = ':' THEN
FileName[l] := 'X';
Dec(l);
END;
IF FileName[0] > #8 THEN FileName[0] := #8;
(*
IF Path = '' THEN BEGIN
Path := DownLoadPath;
IF Path[Length(Path)] <> '\' THEN
Path := Path + '\';
END;
*)
OriginalName := Path+FileName+Ext;
MainName := Copy(FileName+'________',1,8);
l := 1;
FileName := OriginalName;
WHILE Exist(FileName) AND (l<100) DO BEGIN
MainName[8] := Chr(l MOD 10 + 48);
IF l>9 THEN MainName[7] := Chr(l DIV 10 + 48);
FileName := MainName+Ext;
Inc(l);
END;
IF Exist(FileName) THEN BEGIN
SendAbort('Existing File!');
Ferdig := TRUE;
END
ELSE BEGIN
Assign(fil,FileName);
ReWrite(fil,1);
IF IOresult<>0 THEN BEGIN
SendAbort('Cannot Create File!');
Ferdig := TRUE;
END
ELSE BEGIN
CheckSkip := FALSE;
ValidDate := FALSE;
BufferPtr(BufPtr) := Buffer;
BufCount := BufSize;
Expect := ['A','D','Z'];
StatusString := 'In progress';
WriteStatus;
WriteFileName;
ZeroBytes;
StopFile := FALSE;
Ack(PakkeNr);
END;
END;
LongReply := FALSE;
END;
'A' : BEGIN
GetFileAttr;
IF StopFile THEN
SendPacket(PakkeNr,'Y','N')
ELSE
Ack(PakkeNr);
END;
'Z' : EOF_Packet;
'B' : BEGIN
Ack(PakkeNr);
Ferdig := TRUE;
StatusString := 'Completed';
WriteStatus;
END;
END; { CASE }
LastPk := ptype;
LastNr := PakkeNr;
PakkeNr := Succ(PakkeNr) AND 63;
RetryNr := 0;
WriteTotalNr;
END
ELSE IF (pnr = Chr(32 + LastNr)) AND (ptype = LastPk) THEN BEGIN
Inc(RetryNr);
WriteFeilNr;
IF RetryNr > RetryLimit THEN BEGIN
SendAbort('Too many retries!');
Ferdig := TRUE;
END
ELSE BEGIN
IF ptype = 'S' THEN BEGIN
MakeInitPacket('Y');
SendPakke;
END
ELSE
Ack(LastNr);
END;
END
ELSE IF ptype = 'E' THEN BEGIN
Extract(ErrorString);
IF ErrorString <> 'F10' THEN WriteError;
IF ErrorLevel < 2 THEN ErrorLevel := 2;
Ferdig := TRUE;
END
ELSE IF (ptype = 'D') AND WindowData THEN
WindowReceive
ELSE IF (ptype <> 'Y') AND (ptype <> 'N') AND
(pnr <> Chr(32 + LastNr)) THEN BEGIN
SendAbort('Wrong packet type: '+ptype);
Ferdig := TRUE;
END;
END;
END;
IF NOT ferdig THEN
GetPakke;
UNTIL Ferdig;
IF 'D' IN Expect THEN BEGIN
Close(fil);
IF IOresult = 0 THEN
Erase(fil);
END;
Bell;
ShowStat;
IF LongReply THEN {ShowReply};
END; { ReceiveFiles }
PROCEDURE HostCommand;
BEGIN
ClrLast;
WriteStr('Remote Directory: ');
SendPacket(0,'G','D');
GetPakke;
IF RX_Pac^.ptype = 'Y' THEN BEGIN
Extract(st);
IF st = '' THEN BEGIN
ReceiveFiles(TextF,'');
END
ELSE BEGIN
GotoXY(1,25);
WriteLn(st);
END;
GetF10;
END;
END; {HostCommand}
PROCEDURE FinishServer;
BEGIN
ClrLast;
WriteStr('Logging out remote server: ');
SendPacket(0,'G','F');
GetPakke;
IF RX_Pac^.ptype = 'Y' THEN BEGIN
WriteStr('Done!');
Delay(1000);
END;
END; { FinishServer }
VAR
StartPath : String[80];
PROCEDURE Server;
VAR FilP, FilN, st : String;
ok, ResetTimer : BOOLEAN;
BEGIN
ResetTimer := TRUE;
ClrScr;
REPEAT
IF (ServerTime > 0) AND ResetTimer THEN BEGIN
MaxServer.count := ServerTime * 1092;
MaxServer.UserInt := FALSE;
StartTimer(MaxServer);
END;
CheckType := 1; { First packet is always type 1 }
ClrLast;
WriteStr('Kermit SERVER');
GotoXY(72,MaxY); WriteStr('F10=Exit');
PakkeNr := 0;
GetPakke;
ResetTimer := TRUE;
ShowTimeOut := FALSE;
IF RX_Pac^.pnr = ' ' THEN BEGIN
CASE RX_Pac^.ptype OF
'S' : ReceiveFiles(ServF,'');
'I' : BEGIN
TolkInitPacket;
MakeInitPacket('Y');
SendPakke;
END;
'R' : BEGIN
Extract(FilP);
IF FilP[0] = #0 THEN
ok := FALSE
ELSE BEGIN
IF Pos('.',FilP) = 0 THEN FilP := FilP + '.';
FindFirst(FilP,0,DTA);
ok := DosError = 0;
END;
IF ok THEN
SendManyFiles(FilP)
ELSE
SendAbort('No Files Found!');
END;
'T' : BEGIN
IF ServerTimeOut THEN Nack(PakkeNr);
ResetTimer := FALSE;
END;
'E' : BEGIN
Extract(ErrorString);
IF ErrorString = 'F10' THEN BEGIN
IF ErrorLevel = 0 THEN ErrorLevel := 1;
Exit;
END;
WriteError;
END;
'G' : BEGIN
Extract(st);
IF st[1] IN ['F','L'] THEN BEGIN
Ack(0);
Exit;
END
ELSE
SendAbort('Unknown Generic Command!');
END;
'C' : BEGIN
Extract(st);
IF st = '' THEN st := StartPath;
ChDir(st);
GetDir(0,DownLoadPath);
IF IOresult = 0 THEN ;
SendPacket(PakkeNr,'Y','New dir: '+DownLoadPath);
END;
ELSE SendAbort('Unknown Server Command!');
END;
END
ELSE
Nack(PakkeNr);
UNTIL (ServerTime > 0) AND NOT RunningTimer(MaxServer);
END; {Server}
$I Terminal
PROCEDURE Kermit;
VAR
key : KeyType;
heap : Pointer;
st : String;
i : INTEGER;
BEGIN { Kermit }
Mark(heap);
New(RX_Pac); New(TX_Pac); New(Next_Pac);
IF MemAvail < KermitBufSize + 2048 THEN
KermitBufSize := (MemAvail - 2048) AND $F800;
GetMem(buffer,KermitBufSize+1);
BufSize := KermitBufSize;
AttrPakke := TRUE;
YourMaxLength := 80;
PakkeNr := 0;
ServerTime := 0;
PacketDelay := 0;
r_code := r_ok;
IF ArgC >= 1 THEN BEGIN
ShowTimeOut := TRUE;
CheckType := 1;
Init_Params;
st := ArgV[1];
IF Pos(st,'SERVER') = 1 THEN Server
ELSE IF (Pos(st,'SEND') = 1) AND (ArgC >= 2) THEN SendManyFiles(ArgV[2])
ELSE IF Pos(st,'RECEIVE') = 1 THEN ReceiveFiles(RecF,'')
ELSE IF (Pos(st,'GET') = 1) AND (ArgC >= 2) THEN ReceiveFiles(GetF,ArgV[2])
ELSE BEGIN
GotoXY(1,25);
WriteLn('Usage: Kermit [SERVER] | [SEND <file>] | [RECEIVE] | [GET <file>');
Exit;
END;
END
ELSE BEGIN
REPEAT
ShowTimeOut := TRUE;
CheckType := 1;
Meny(key);
CASE key OF
1 : BEGIN
SendManyFiles('');
GetF10;
END;
2 : BEGIN
ReceiveFiles(RecF,'');
GetF10;
END;
3 : BEGIN
ReceiveFiles(GetF,'');
GetF10;
END;
4 : Server;
5 : SaveParam;
6 : HostCommand;
7 : BEGIN
GotoXY(1,25); WriteLn; CursorOn; Exec(FindEnv('COMSPEC='),'');
IF DosError <> 0 THEN BEGIN
WriteLn('EXEC error # ',DosError);
Delay(2000);
END;
END;
8 : BEGIN
GotoXY(1,25);
ClrEol;
GotoXY(72,25); Write('F10-Exit');
Window(1,18,80,24);
ClrScr;
CursorOn;
Terminal;
Window(1,1,80,25);
END;
9 : FinishServer;
END;
UNTIL key = 10;
END;
Release(heap);
END; { Kermit }
VAR
ok : BOOLEAN;
ch : CHAR;
key : WORD;
CONST
US_Tab : ARRAY [1..6] OF CHAR = '[\]{|}';
NO_Tab : ARRAY [1..6] OF CHAR = '';
BEGIN {Kermits}
CheckBreak := FALSE;
FileMode := 0;
OrigText := TextAttr;
OrigMenu := OrigText XOR 8;
OrigField := FeltAttr;
OrigEdit := EditAttr;
GetDir(0,StartPath); DownLoadPath := StartPath;
FOR ch := #0 TO #255 DO InnConvert[ch] := ch;
UtConvert := InnConvert;
FOR key := 1 TO 6 DO BEGIN
InnConvert[US_Tab[key]] := NO_Tab[key];
UtConvert[NO_Tab[key]] := US_Tab[key];
END;
RS_MakeBuffer($1000,0,0,0,0); {Use same buffers for all ports!}
MakeStr(4,5,64,LeftJ,'Current Dir: ',DownLoadPath,Addr(FileNameSet),ToUpper);
MakeLong(10,7,6,LeftJ,'Baud: ',CurBaud,2,115200);
MakeWord(10,8,1,LeftJ,'Bits: ',CurBits,7,8);
MakeEnum(8,9,5,CenterJ,'Parity: ',CurParity,5,ParityStr);
MakeWord(5,10,1,LeftJ,'Stop Bits: ',CurStop,1,2);
MakeWord(6,11,1,LeftJ,'Com Port: ',CurComPort,1,4);
MakeWord(32,7,4,LeftJ, 'Max Packet: ',LongMaxLength,20,9020);
MakeWord(32,8,2,LeftJ, 'Max Window: ',WinSize,0,31);
MakeWord(28,9,3,LeftJ, 'Packet Timeout: ',MyTimeOut,0,120);
MakeWord(28,10,3,LeftJ,'Server Timeout: ',ServerTime,0,500);
MakeByte(32,11,1,LeftJ,'Check Type: ',FileCheck,1,3);
MakeBool(58,7,5,LeftJ, 'Long Packets: ',LongPakke);
MakeBool(56,8,5,LeftJ, 'Sliding Window: ',WindowData);
MakeEnum(61,9,4,LeftJ, 'File Type: ',TextFile,2,BinText);
MakeEnum(62,10,3,LeftJ, 'IBM Mode: ',IBM_Mode,3,Std_IBM);
MakeBool(60,11,5,LeftJ,'High Speed: ',BinaryData);
MakeByte(2,13,2,LeftJ, 'Packet Start: ',BYTE(MySOH),1,31);
MakeByte(4,14,2,LeftJ, 'Packet End: ',BYTE(MyCR),1,31);
MakeChar(4,15,1,LeftJ, 'Ctl Prefix: ',MyQCtrlChar,NIL,0);
MakeChar(3,16,1,LeftJ, '8bit Prefix: ',Q8bitChar,NIL,0);
MakeChar(4,17,1,LeftJ, 'Rep Prefix: ',QrepChar,NIL,0);
MakeEnum(34,15,10,CenterJ,' No Date: ',DupHandle,3,DupString);
MakeEnum(34,16,10,CenterJ,'Old File: ',OldDupHandle,3,DupString);
MakeEnum(34,17,10,CenterJ,'New File: ',NewDupHandle,3,DupString);
MakeByte(60,13,3,LeftJ, 'Text Color: ',KermitAttr,0,255);
MakeByte(60,14,3,LeftJ, 'Menu Color: ',MenuAttr,0,255);
MakeByte(59,15,3,LeftJ,'Field Color: ',FieldAttr,0,255);
MakeByte(60,16,3,LeftJ, 'Edit Color: ',EditAttr,0,255);
MakeBool(58,17,5,LeftJ,'Direct Video: ',DirVideo);
IF NOT GetParam THEN Halt(1);
DirectVideo := DirVideo;
ClrScr; {Keep current screen colors!}
CursorOff;
Kermit;
CursorOn;
RS_Stop(CurComPort);
ChDir(StartPath);
GotoXY(1,25);
END.