UNIT CISBXfer;
INTERFACE
{ This unit will perform Compuserve B Protocol file transfers in both
binary and text file formats.
The FUNCTION DoTransfer should be called whenever an ENQ (5) is received
from the host. DoTransfer returns TRUE IF the file transfer was successful
and FALSE IF not.
}
FUNCTION DoTransfer:BOOLEAN;
IMPLEMENTATION
FUNCTION DoTransfer{ : BOOLEAN};
{***************
**
** This module implements the B-Protocol Functions for terminal.pas.
** The only procedures this routine requires that are not located here
** are send and cgetc. These routines should be as follows:
**
** PROCEDURE Send(ch : INTEGER);
** (*This PROCEDURE sends the character who's ordinal value is CH to the
** async port*)
**
** FUNCTION cgetc(wait_time : INTEGER) : INTEGER;
** (*This FUNCTION waits approximately WAIT_TIME seconds for a character
** at the async port. If no character is received, -1 is returned,
** otherwise the ordinal value of the received character is returned*)
**
** These definitions should be sufficient to implement B-Protocol in a
** pascal program. The routine DO_TRANSFER should be invoked whenever a
** ENQ (ascii value 5) is received from the host. It returns TRUE IF the
** operation it performs is successful.
**
** If you have any questions contact me, Jim Nutt, at either 76044,1155 or
** 71076,1434 on CIS, or at FIDOnet Node 452.
****************}
{*************************************************
Changes by Tom Cattrall 72767,622 June 21, 1986:
-- Downloaded from Borland Forum DL and changed from Turbo Pascal to
UCSD Pascal as needed.
-- Fixed loopholes in error checking and recovery
-- Added check for console keypress to abort transfer.
-- End of line for text files was changed to add LF on send and strip the
LF on receive.
-- Seperated out binary file from text file handling due to P-System's
way of dealing with text files. Binary files are treated as a file of
integers. If the binary file received has an odd number of bytes then
a 0 is appended and a warning message is given. Binary file transfers
haven't been checked extensively so beware. In particular, testing was
done on a 68000 machine and byte sex dependencies may be present that
cause trouble on other machines.
Changes by Tom Cattrall July 25, 1986
-- Changed byte counter to REAL so that transfers of more than 32767 bytes
will be represented properly.
-- Added packet error counter and a write to display the current bytes
transferred and the total nb of packet errors so far.
-- Write message saying that Compuserve B protocol transfer has been
entered. Occasionally line noise will produce an ENQ which causes this
unit to be entered spuriously. If you see the message when no transfer
is supposed to take place then hit any key to cause a packet error which
will cause the unit to exit.
**************************************************}
{$P}
const xmt_size = 511;
rcv_size = 512;
max_errors = 10;
{ Sender actions }
s_send_packet = 0;
s_get_dle = 1;
s_get_num = 2;
s_get_seq = 3;
s_get_data = 4;
s_get_checksum = 5;
s_timed_out = 6;
s_send_nak = 7;
{ Receiver actions }
r_get_dle = 0;
r_get_b = 1;
r_get_seq = 2;
r_get_data = 3;
r_get_checksum = 4;
r_send_nak = 5;
r_send_ack = 6;
{Other Constants}
xmt_col = 50;
rcv_col = 36;
CR = 13;
LF = 10;
xon = 17;
xoff = 19;
dle = 16;
etx = 03;
nak = 21;
enq = 05;
wack = 59;
{$P}
TYPE
aFileType = (binary,ascii);
byte = 0..255;
lstr = string[255];
buffertype = ARRAY [0..520] of byte;
anAsciiFile= TEXT;
aBinFile = FILE OF PACKED RECORD
l, r : byte;
END;
var
timer,
r_size, { size of receiver buffer }
checksum,
seq_num,
ch : INTEGER; { current character }
c1 : CHAR;
s1 : STRING[1];
lastWasCR : BOOLEAN;
kBInterupt : BOOLEAN;
xoff_flag,
timed_out, { we timed out before receiving character }
masked : BOOLEAN;
{ true IF ctrl character was 'masked' }
s_buffer : buffertype;
r_buffer : buffertype;
filename : lstr; { pathname }
i, n : INTEGER;
dummy : BOOLEAN;
s_counter : byte;
r_counter : byte;
fileType : aFileType;
totalBytes : REAL; {Total bytes transferred}
totalErrors : INTEGER; {Total errors during transfer}
{$P}
PROCEDURE Send(ch:INTEGER);
VAR
data : STRING[2];
BEGIN
data:= ' ';
data[1]:= CHR(ch);
unitwrite(8,data[1],1,,4);
END;
FUNCTION cgetc(w:INTEGER):INTEGER;
VAR
lo,hi,oldlo : INTEGER;
timeleft : INTEGER;
done : BOOLEAN;
data : STRING[2];
status2,
status7 : PACKED ARRAY [0..29] OF INTEGER;
BEGIN
data:= ' ';
done:= FALSE;
timeleft:= w* 60;
time(hi, oldlo);
WHILE NOT done AND (timeleft > 0) DO
BEGIN
unitstatus(7,status7,1);
IF status7[0] = 0 THEN
BEGIN
time(hi, lo);
IF lo <> oldlo THEN
BEGIN
oldlo:= abs(lo-oldlo);
IF oldlo > 30 THEN oldlo:= 30;
timeleft:= timeleft - oldlo;
oldlo:= lo;
UNITSTATUS(2,status2,1);
IF status2[0] <> 0 THEN timeleft:= -1;
END
END
ELSE
BEGIN
unitread(7,data[1],1);
cgetc:= ORD ( data[1]);
done:= TRUE;
END;
END; {WHILE}
IF timeleft = 0 THEN cgetc:= -1
ELSE IF timeleft = -1 THEN cgetc:= -2;
END;
{$P}
PROCEDURE Send_masked_byte(ch : INTEGER);
BEGIN
IF ch < 32
THEN
BEGIN
send(dle);
send(ch + ord('@'));
END
ELSE
send(ch);
s_counter := (s_counter + 1) mod 64;
IF s_counter = 0 THEN write('.');
END;
PROCEDURE Send_ack;
BEGIN
write('!');
send(dle);
send(seq_num + ord('0'));
END;
PROCEDURE send_nak;
BEGIN
write('?');
send(nak);
END;
PROCEDURE send_enq;
BEGIN
write('(');
send(enq);
END;
{$P}
FUNCTION read_byte : BOOLEAN;
BEGIN
timed_out := false;
ch := cgetc(timer);
IF ch < 0 THEN
BEGIN
kBInterupt := ch = -2;
read_byte := false;
exit(read_byte);
END;
r_counter := (r_counter + 1) mod 64;
IF r_counter = 0 THEN write('+');
read_byte := true;
END;
FUNCTION read_masked_byte : BOOLEAN;
BEGIN
masked := false;
IF NOT read_byte THEN
BEGIN
read_masked_byte := false;
exit(read_masked_byte);
END;
IF (ch = dle) THEN
BEGIN
IF (read_byte = false) THEN
BEGIN
read_masked_byte := false;
exit(read_masked_byte);
END;
ch := ch MOD 32;
masked := true;
END;
read_masked_byte := true;
END;
{$N+}PROCEDURE DO_checksum(ch : INTEGER);
BEGIN
checksum := (checksum + checksum);
IF checksum > 255 THEN checksum:= (checksum MOD 256) + 1;
checksum := (checksum + ch);
IF checksum > 255 THEN checksum:= (checksum MOD 256) + 1;
END;{$N-}
{$P}
FUNCTION send_packet(size: INTEGER) : BOOLEAN;
var
action,
errors,
next_seq,
block_num,
i : INTEGER;
sent_enq : BOOLEAN;
BEGIN
next_seq := (seq_num + 1) mod 10;
errors := 0;
kBInterupt:= FALSE;
sent_enq := false;
action := s_send_packet;
WHILE true DO
CASE (action) of
s_send_packet: BEGIN
checksum := 0;
send(dle);
send(ord('B'));
send(next_seq + ord('0'));
DO_checksum(next_seq + ord('0'));
FOR i := 0 to size DO
BEGIN
send_masked_byte(s_buffer[i]);
DO_checksum(s_buffer[i]);
END;
send(etx);
DO_checksum(etx);
send_masked_byte(checksum);
action := s_get_dle;
END;
s_get_dle: BEGIN
timer := 30;
IF (read_byte = false)
THEN action := s_timed_out
ELSE IF (ch = dle)
THEN action := s_get_num
ELSE IF (ch = nak)
THEN
BEGIN
errors := errors + 1;
totalErrors:= totalErrors + 1;
IF (errors > max_errors)
THEN BEGIN
send_packet := false;
exit(send_packet);
END;
action := s_send_packet;
END
ELSE IF (ch = etx)
THEN action := s_send_nak;
END;
s_get_num: BEGIN
timer := 30;
IF (read_byte = false)
THEN action := s_timed_out
ELSE IF (ch >= ord('0')) and (ch <= ord('9'))
THEN
BEGIN
IF (ch - ord('0') = seq_num)
THEN
IF (sent_enq)
THEN action := s_send_packet
ELSE action := s_get_dle
ELSE
IF (ch - ord('0') = next_seq)
THEN
BEGIN
seq_num := next_seq;
send_packet := true;
exit(send_packet);
END
ELSE
IF (errors = 0)
THEN action := s_send_packet
ELSE action := s_get_dle;
END
ELSE IF (ch = nak)
THEN action := s_send_packet
ELSE IF (ch = wack)
THEN
BEGIN
timer := timer + 10;
action := s_get_dle;
END
ELSE IF (ch = ord('B'))
THEN action := s_get_seq
ELSE IF (ch = etx)
THEN action := s_send_nak
ELSE action := s_get_dle;
END;
s_get_seq: BEGIN
timer := 10;
IF (read_byte = false)
THEN action := s_send_nak
ELSE
BEGIN
checksum := 0;
block_num := ch - ord('0');
DO_checksum(ch);
i := 0;
action := s_get_data;
END;
END;
s_get_data: BEGIN
timer := 10;
IF (read_masked_byte = false)
THEN action := s_send_nak
ELSE IF ((ch = etx) and not masked)
THEN
BEGIN
DO_checksum(etx);
action := s_get_checksum;
END
ELSE
BEGIN
r_buffer[i] := ch;
i := i + 1;
DO_checksum(ch);
END;
END;
s_get_checksum: BEGIN
timer := 10;
IF (read_masked_byte = false)
THEN action := s_send_nak
ELSE IF (ch <> checksum)
THEN action := s_send_nak
ELSE IF (block_num <> (next_seq + 1) mod 10)
THEN action := s_send_nak
ELSE
BEGIN
seq_num := block_num;
send_ack;
r_size := i;
send_packet := true;
exit(send_packet);
END;
END;
s_timed_out: BEGIN
errors := errors + 1;
totalErrors:= totalErrors + 1;
IF (errors > 4) OR kBInterupt
THEN BEGIN
send_packet := false;
exit(send_packet);
END;
action := s_get_dle;
END;
s_send_nak: BEGIN
errors := errors + 1;
totalErrors:= totalErrors + 1;
IF (errors > max_errors) OR kBInterupt
THEN BEGIN
send_packet := false;
exit(send_packet);
END;
send_nak;
action := s_get_dle;
END;
END;
END; { SEND_Packet }
PROCEDURE Send_failure(code : char);
var dummy : BOOLEAN;
BEGIN
s_buffer[0] := ord('F');
s_buffer[1] := ord(code);
dummy := send_packet(2);
END;
{$P}
FUNCTION send_file(name : lstr) : BOOLEAN;
var n : INTEGER;
oddByte : BOOLEAN;
binFile : aBinFile;
asciiFile : anAsciiFile;
FUNCTION ReadAsciiFile(n, xmt_size : INTEGER) : INTEGER;
var i : INTEGER;
c : CHAR;
BEGIN
i := n;
WHILE (not eof(asciiFile)) and (xmt_size > 0) DO
BEGIN
IF lastWasCR THEN
BEGIN
s_buffer[i]:= LF;
lastWasCR:= FALSE;
END
ELSE
IF eoln(asciiFile) THEN
BEGIN
READ (asciiFile, c);
s_buffer[i]:= CR;
lastWasCR:= TRUE;
END
ELSE
BEGIN
READ(asciiFile, c);
s_buffer[i]:= ORD(c);
END;
i := i + 1;
xmt_size := xmt_size - 1;
END;
ReadAsciiFile := i - n;
END;
{$P}
FUNCTION ReadBinaryFile(n, xmt_size : INTEGER) : INTEGER;
var i : INTEGER;
BEGIN
i := n;
WHILE (not eof(binFile)) and (xmt_size > 0) DO
BEGIN
IF oddByte THEN
BEGIN
s_Buffer[i]:= binFile^.l;
oddByte:= FALSE;
END
ELSE
BEGIN
s_Buffer[i]:= binFile^.r;
get(binFile);
oddByte:= TRUE;
END;
i := i + 1;
xmt_size := xmt_size - 1;
END; {WHILE}
IF (xmt_size > 0) AND NOT oddByte THEN
BEGIN
s_buffer[i]:= binFile^.r;
get(binFile);
i:= i+1;
oddByte:= TRUE;
END;
ReadBinaryFile := i - n;
END;
BEGIN
{$i-}
CASE fileType OF
ascii : reset(asciiFile,name);
binary: reset(binFile,name);
END; {CASE}
{$i+}
IF (ioresult > 0) THEN
BEGIN
send_failure('E');
send_file := false;
exit(send_file);
END;
lastWasCR:= FALSE;
oddByte:= TRUE;
totalBytes:= 0.0;
totalErrors:= 0;
REPEAT
s_buffer[0] := ord('N');
CASE fileType OF
ascii : n := ReadAsciiFile(1, xmt_size);
binary : n := ReadBinaryFile(1,xmt_size);
END; {CASE}
totalBytes:= totalBytes + n;
writeln(totalBytes:7:0, ' bytes, ', totalErrors:4, ' errors');
IF (n > 0) THEN
IF (send_packet(n) = false) THEN
BEGIN
send_file := false;
exit(send_file);
END;
UNTIL not (n > 0);
WRITE('Transfer complete, ',totalBytes:4:0,' bytes transferred with ');
WRITELN(totalErrors:1,' packet errors');
{ Inform host that the file was sent }
s_buffer[0] := ord('T');
s_buffer[1] := ord('C');
send_File:= send_Packet(2);
exit(send_File);
END; { SEND_File }
{$P}
FUNCTION read_packet : BOOLEAN;
{True IF packet is available from host}
var
action,
next_seq,
block_num,
errors,
i : INTEGER;
BEGIN
fillchar(r_buffer,520,0);
next_seq := (seq_num + 1) mod 10;
errors := 0;
kBInterupt:= FALSE;
action := r_get_dle;
WHILE true DO
BEGIN
timer := 10;
CASE (action) of
r_get_dle: BEGIN
IF (read_byte = false)
THEN action := r_send_nak
ELSE IF ((ch MOD 128) = dle)
THEN action := r_get_b
ELSE IF ((ch MOD 128) = enq)
THEN action := r_send_ack;
END;
r_get_b: BEGIN
IF (read_byte = false)
THEN action := r_send_nak
ELSE IF ((ch MOD 128) = ord('B'))
THEN action := r_get_seq
ELSE IF (ch = enq)
THEN action := r_send_ack
ELSE action := r_get_dle;
END;
r_get_seq: BEGIN
IF (read_byte = false)
THEN action := r_send_nak
ELSE IF (ch = enq)
THEN action := r_send_ack
ELSE
BEGIN
checksum := 0;
block_num := ch - ord('0');
DO_checksum(ch);
i := 0;
action := r_get_data;
END;
END;
r_get_data: BEGIN
IF (read_masked_byte = false)
THEN action := r_send_nak
ELSE IF ((ch = etx) and not masked)
THEN
BEGIN
DO_checksum(etx);
action := r_get_checksum;
END
ELSE
BEGIN
r_buffer[i] := ch;
i := i + 1;
DO_checksum(ch);
END;
END;
r_get_checksum: BEGIN
IF (read_masked_byte = false)
THEN action := r_send_nak
ELSE IF (ch <> checksum)
THEN action := r_send_nak
ELSE IF (block_num = seq_num)
THEN
BEGIN
IF (r_buffer[0] = ord('F'))
THEN
BEGIN
seq_num := block_num;
r_size := i;
read_packet := true;
exit(read_packet);
END
ELSE
action := r_send_ack;
END
ELSE IF (block_num <> next_seq)
THEN action := r_send_nak
ELSE
BEGIN
seq_num := block_num;
r_size := i;
read_packet := true;
exit(read_packet);
END;
END;
r_send_nak: BEGIN
errors := errors + 1;
totalErrors:= totalErrors + 1;
IF (errors > max_errors) OR kBInterupt
THEN BEGIN
read_packet := false;
exit(read_packet);
END;
send_nak;
action := r_get_dle;
END;
r_send_ack: BEGIN
send_ack;
action := r_get_dle; { wait for the next block }
END;
END;
END;
END; { Read_Packet }
{$P}
FUNCTION receive_file(name : lstr) : BOOLEAN;
var
asciiFile : anAsciiFile;
binFile : aBinFile;
status : INTEGER;
oddByte : BOOLEAN;
FUNCTION write_file(n, size : INTEGER) : INTEGER;
var i : INTEGER;
c : INTEGER;
BEGIN
CASE fileType OF
ascii : BEGIN
FOR i := 1 to size DO
BEGIN
c:= r_buffer[n + i - 1];
IF c = CR THEN WRITELN(asciiFile)
ELSE IF c <> LF THEN WRITE(asciiFile,CHR(c));
END;
END;
binary: BEGIN
FOR i:= 1 TO size DO
IF oddByte THEN
BEGIN
binFile^.l:= r_buffer[n+i-1];
oddByte:= FALSE;
END
ELSE
BEGIN
binFile^.r:= r_buffer[n+i-1];
put(binFile);
oddByte:= TRUE;
END;
END;
END; {CASE}
END;
BEGIN
{$i-}
CASE fileType OF
ascii : rewrite(asciiFile,name);
binary: rewrite(binFIle,name);
END; {CASE}
{$I+}
IF (ioresult > 0) THEN
BEGIN
send_failure('E');
receive_file := false;
exit(receive_file);
END;
send_ack;
oddByte:= TRUE;
totalBytes:= 0.0;
totalErrors:= 0;
WHILE true DO
BEGIN
writeln(totalBytes:7:0, ' bytes, ', totalErrors:4, ' errors');
IF read_packet THEN
BEGIN
CASE chr(r_buffer[0]) of
'N': BEGIN
status := write_file(1,r_size - 1);
totalBytes:= totalBytes + r_size -1.0;
send_ack;
END;
'T': BEGIN
IF r_buffer[1] =
