home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.wwiv.com
/
ftp.wwiv.com.zip
/
ftp.wwiv.com
/
pub
/
PROTOCOL
/
WXTRM305.ZIP
/
WXTMXFER.INC
< prev
Wrap
Text File
|
1991-08-12
|
41KB
|
1,110 lines
{ - originally written by:
Scott Murphy
77 So. Adams St. #301
Denver, CO 80209
Compuserve 70156,263
}
{ - modified to add CRC xmodem, wxmodem 7/86 - 10/86
Peter Boswell
ADI
Suite 650
350 N. Clark St.
Chicago, Il 60610
People/Link: Topper
Compuserve : 72247,3671
}
{ converted to Turbo Pascal 5.0/5.5 L.B. Neal June 1990 }
CONST
SOH = 1; {Start Of Header}
EOT = 4; {End Of Transmission}
ACK = 6; {ACKnowledge}
DLE = $10; {Data Link Escape}
XON = $11; {X-On}
XOFF = $13; {X-Off}
NAK = $15; {Negative AcKnowledge}
SYN = $16; {Synchronize}
CAN = $18; {CANcel}
CHARC = $43; {C = CRC Xmodem}
CHARW = $57; {W = WXmodem}
MAXERRS = 10; {Maximum allowed errors}
L = 0;
H = 1;
BufLen = 128; {Disk I/O buffer length}
Bufnum = 64; {Disk I/O buffer count}
Maxwindow = 4; {Wxmodem window size}
(* crctab calculated by Mark G. Mendel, Network Systems Corporation *)
CONST crctab: ARRAY[0..255] OF WORD = (
$0000, $1021, $2042, $3063, $4084, $50a5, $60c6, $70e7,
$8108, $9129, $a14a, $b16b, $c18c, $d1ad, $e1ce, $f1ef,
$1231, $0210, $3273, $2252, $52b5, $4294, $72f7, $62d6,
$9339, $8318, $b37b, $a35a, $d3bd, $c39c, $f3ff, $e3de,
$2462, $3443, $0420, $1401, $64e6, $74c7, $44a4, $5485,
$a56a, $b54b, $8528, $9509, $e5ee, $f5cf, $c5ac, $d58d,
$3653, $2672, $1611, $0630, $76d7, $66f6, $5695, $46b4,
$b75b, $a77a, $9719, $8738, $f7df, $e7fe, $d79d, $c7bc,
$48c4, $58e5, $6886, $78a7, $0840, $1861, $2802, $3823,
$c9cc, $d9ed, $e98e, $f9af, $8948, $9969, $a90a, $b92b,
$5af5, $4ad4, $7ab7, $6a96, $1a71, $0a50, $3a33, $2a12,
$dbfd, $cbdc, $fbbf, $eb9e, $9b79, $8b58, $bb3b, $ab1a,
$6ca6, $7c87, $4ce4, $5cc5, $2c22, $3c03, $0c60, $1c41,
$edae, $fd8f, $cdec, $ddcd, $ad2a, $bd0b, $8d68, $9d49,
$7e97, $6eb6, $5ed5, $4ef4, $3e13, $2e32, $1e51, $0e70,
$ff9f, $efbe, $dfdd, $cffc, $bf1b, $af3a, $9f59, $8f78,
$9188, $81a9, $b1ca, $a1eb, $d10c, $c12d, $f14e, $e16f,
$1080, $00a1, $30c2, $20e3, $5004, $4025, $7046, $6067,
$83b9, $9398, $a3fb, $b3da, $c33d, $d31c, $e37f, $f35e,
$02b1, $1290, $22f3, $32d2, $4235, $5214, $6277, $7256,
$b5ea, $a5cb, $95a8, $8589, $f56e, $e54f, $d52c, $c50d,
$34e2, $24c3, $14a0, $0481, $7466, $6447, $5424, $4405,
$a7db, $b7fa, $8799, $97b8, $e75f, $f77e, $c71d, $d73c,
$26d3, $36f2, $0691, $16b0, $6657, $7676, $4615, $5634,
$d94c, $c96d, $f90e, $e92f, $99c8, $89e9, $b98a, $a9ab,
$5844, $4865, $7806, $6827, $18c0, $08e1, $3882, $28a3,
$cb7d, $db5c, $eb3f, $fb1e, $8bf9, $9bd8, $abbb, $bb9a,
$4a75, $5a54, $6a37, $7a16, $0af1, $1ad0, $2ab3, $3a92,
$fd2e, $ed0f, $dd6c, $cd4d, $bdaa, $ad8b, $9de8, $8dc9,
$7c26, $6c07, $5c64, $4c45, $3ca2, $2c83, $1ce0, $0cc1,
$ef1f, $ff3e, $cf5d, $df7c, $af9b, $bfba, $8fd9, $9ff8,
$6e17, $7e36, $4e55, $5e74, $2e93, $3eb2, $0ed1, $1ef0
);
(*
* updcrc derived from article Copyright (C) 1986 Stephen Satchell.
* NOTE: First argument must be in range 0 to 255.
* Second argument is referenced twice.
*
* Programmers may incorporate any or all code into their programs,
* giving proper credit within the source. Publication of the
* source routines is permitted so long as proper credit is given
* to Stephen Satchell, Satchell Evaluations and Chuck Forsberg,
* Omen Technology.
*)
VAR
checksum : Integer;
fname : bigstring;
response : Char; { 3.04 }
crcval, db, sb : Integer;
packetln : Integer; {128 + Checksum or 128 + CRC}
p : parity_set;
dbuffer : ARRAY[1..Bufnum, 1..BufLen] OF Byte;
dcount : Integer;
Wxmode,Crcmode,Openflag : Boolean;
(* ----------------------- now called directly used twice 3.04
PROCEDURE updcrc(a:Byte);
BEGIN
crcval := Crctab[hi(crcval) xor a] xor (lo(crcval) shl 8);
END;
------------------------- *)
{$R-,S-}
FUNCTION cgetc(TimeLimit: Integer): Integer;
{if a byte is recieved at COM1/COM2: in less than TimeLimit seconds,
returns byte as an integer, else returns 0}
BEGIN
TimeLimit := TimeLimit SHL 10; {convert TimeLimit to millisecs}
WHILE (Buffer_Count < 1) AND (TimeLimit > 0) DO
BEGIN
Delay(1); DEC(TimeLimit);
END;
IF ( (TimeLimit >= 0) AND (Buffer_Count > 0) ) THEN
BEGIN
INLINE($FA); {suspend interrupts}
cgetc := Recv_Buffer[buffer_Tail];
IF Buffer_Tail < Buffer_End THEN { 3.04 safer this way }
INC(Buffer_Tail)
ELSE
Buffer_Tail := 1;
DEC(Buffer_Count);
INLINE($FB); {resume interrupts}
END
ELSE
cgetc := -1;
END;
{ Xmodem transmit window routine
Peter Boswell, July 1986 }
PROCEDURE txwindow(opt:Integer; in_string:bigstring);
BEGIN
IF opt > 1 THEN INC(opt); { adjust new window 3.04 }
CASE opt OF
1 : BEGIN {initialize}
DoBorder(36,3,78,18);
GoToXY(10,2);
Write('File - ', in_string);
GoToXY(10,3);
Write('Mode -');
GoToXY(4,4);
Write('Total time -');
GoToXY(2,5);
Write('Total Blocks -');
GoToXY(10,6);
Write('Sent -');
GoToXY(9,7);
Write('ACK''d -');
GoToXY(6,8);
Write('Last NAK -');
GoToXY(9,9);
Write('X-Off - No');
GoToXY(8,10);
Write('Window - 0');
GoToXY(4,12);
Write('Last Error -');
GoToXY(8,11);
Write('Errors -');
END;
3..12 : BEGIN {3.04}
GoToXY(17,opt);
{ClrEol;}
Write(in_string);
END;
13 : BEGIN{3.04}
GoToXY(3, 13);
{ClrEol;}
Write(in_string);
END;
100 : BEGIN ClrScr; Window(1,1,80,24); END;
END; {case}
END;
{ Xmodem receive window routine
Peter Boswell, October 1986 }
PROCEDURE trwindow(opt:Integer; in_string:bigstring);
BEGIN
IF opt > 1 THEN INC(opt); {3.04}
CASE opt OF
1 : BEGIN {initialize}
DoBorder(36,3,78,13);
GoToXY(10, 2);
Write('File - ', in_string);
GoToXY(10, 3);
Write('Mode -');
GoToXY(6, 4);
Write('Received -');
GoToXY(6, 5);
Write('Last NAK -');
GoToXY(4, 6);
Write('Last Error -');
GoToXY(8, 7);
Write('Errors -');
END;
3..7 : BEGIN
GoToXY(17, opt);
{ClrEol;}
Write(in_string);
END;
9 : BEGIN
GoToXY(3,9);
{ClrEol;}
Write(in_string);
END;
100 : BEGIN ClrScr; Window(1,1,80,24); END;
END;{case}
END;
{ This routine deletes all DLE characters and XOR's the following character
with 64. If a SYN character is found then -2 is returned. }
FUNCTION dlecgetc(Tlimit:Integer):Integer;
VAR savecgetc : Integer;
BEGIN
IF wxmode THEN
BEGIN
savecgetc := cgetc(Tlimit);
IF savecgetc = SYN THEN
savecgetc := -2
ELSE
IF savecgetc = DLE THEN
BEGIN
savecgetc := cgetc(Tlimit);
IF savecgetc >= 0 THEN savecgetc := savecgetc XOR 64;
END;
dlecgetc := savecgetc;
END
ELSE
dlecgetc := cgetc(Tlimit);
END;
PROCEDURE purge;
BEGIN
WHILE dlecgetc(1) >= 0 DO{NOP};
END;
PROCEDURE SaveCommStatus;
BEGIN
p := parity;
db := dbits;
sb := stop_bits;
dbits := 8;
parity := none;
stop_bits := 1;
{update_uart;}
END;
PROCEDURE recv_wcp; {receive using Ward Christensen's checksum protocol}
LABEL Exit_recv_wcp; {3.04}
VAR
j, firstchar, sectnum, sectcurr, prevchar, lignore, blkcnt,
toterr, errors, sectcomp, bufcurr, bresult : Integer;
Xtrace, EotFlag, ErrorFlag, Extend : Boolean;
UserKey : Byte;
blkfile : FILE;
statstr : bigstring;
trfile : Text;
BEGIN
Gotoxy(2,1); Write('RECV XMODEM');
ErrorFlag := True;
EotFlag := False;
Xtrace := False;
Openflag := False;
Bufcurr := 1;
SaveCommStatus;
WHILE ErrorFlag DO
BEGIN
DoBorder(1,3,80,8);
REPEAT
GotoXy(3,2);
Write('Enter download filename or <cr> abort:'); {Chd 3.01}
ReadLn(fname);
supcase(fname);
IF Length(fname) > 0 THEN
IF exists(fname) THEN
BEGIN
Gotoxy(3,4);
Write(fname,' Exists. OK to overwrite it(Y/N)?');
REPEAT
response := Upcase(ReadKey);
UNTIL (response = 'Y') OR (response = 'N');
IF response = 'Y' THEN ErrorFlag := False;
END
ELSE ErrorFlag := False
UNTIL (NOT ErrorFlag) OR (Length(fname) = 0);
BEGIN ClrScr; Window(1,1,80,24); END;
IF Length(fname) > 0 THEN
BEGIN
Assign(blkfile, fname);
{$I-} Rewrite(blkfile); {$I+}
ErrorFlag := (IOResult <> 0);
IF ErrorFlag THEN
BEGIN
WriteLn(#13, #10, 'WXTERM --- cannot open file.'); {Chd 3.01}
GOTO Exit_recv_wcp; {3.04}
END
ELSE
openflag := True;
END;
IF Length(fname) = 0 THEN
BEGIN
WriteLn(#13, #10, 'WXTERM --- user aborted receive.'); {Chd 3.01}
GOTO Exit_recv_wcp; {3.04}
END;
END; {while}
trwindow(1,fname);
blkcnt := 0;
sectnum := 0;
errors := 0;
toterr := 0;
{assign(trfile,'trace');}
{rewrite(trfile);}
Crcmode := True; {Assume CRC versus Checksum}
Packetln := 130; {128 byte data + 2 byte CRC}
Wxmode := True; {Assume Wxmodem}
Lignore := 0; {ignore packets after error}
i := 0; {Try for Wxmodem 3 times}
dump; {purge;}
trwindow(8, 'Trying Wxmodem.'); {Chd 3.01}
REPEAT
send(ORD('W'));
firstchar := cgetc(12); {12 seconds each}
IF Keypressed THEN
BEGIN
userkey := ORD(readkey);
IF UserKey = CAN THEN GOTO Exit_recv_wcp; {3.04}
END;
INC(i);
UNTIL (firstchar = SYN) OR (firstchar = CAN) OR (i = 3);
IF firstchar = CAN THEN GOTO Exit_recv_wcp; {3.04}
IF firstchar <> SYN THEN
BEGIN
Wxmode := False;
i := 0; {Try CRC xmodem 3 times}
trwindow(8, 'Trying CRC Xmodem.'); {Chd 3.01}
REPEAT
send(ORD('C'));
firstchar := cgetc(4); {4 seconds each}
IF Keypressed THEN
BEGIN
UserKey := ORD(readkey);
IF UserKey = CAN THEN GOTO Exit_recv_wcp; {3.04}
END;
INC(i);
UNTIL (firstchar = SOH) OR (firstchar = CAN) OR (i = 3);
IF firstchar = CAN THEN GOTO Exit_recv_wcp; {3.04}
IF firstchar <> SOH THEN
BEGIN
Crcmode := False;
Packetln := 129; {128 bytes + 1 byte Checksum}
i := 0; {Try Checksum xmodem 4 times}
trwindow(5, 'Trying Checksum Xmodem.'); {Chd 3.01}
REPEAT
send(NAK);
firstchar := cgetc(10); {10 seconds each}
IF KeyPressed THEN
BEGIN
UserKey := ORD(readkey);
IF UserKey = CAN THEN GOTO Exit_recv_wcp; {3.04}
END;
INC(i);
UNTIL (firstchar = SOH) OR (firstchar = CAN) OR (i = 4);
END; {Checksum}
END; {CRC}
IF wxmode THEN
BEGIN
trwindow(2, 'WXmodem. '); {Chd 3.01}
END;
IF NOT wxmode AND crcmode THEN
BEGIN
trwindow(2, 'CRC Xmodem. '); {Chd 3.01}
END;
IF NOT wxmode AND NOT crcmode THEN
BEGIN
trwindow(2, 'CSUM Xmodem.'); {Chd 3.04}
END;
trwindow(8, 'Press ^X to quit');
{ firstchar contains the first character and Wxmode and Crcmode
indicate the type of Xmodem }
prevchar := firstchar; {save the firstchar}
WHILE (EotFlag = False) AND (Errors < MAXERRS) DO {3.04}
BEGIN {locate start of packet}
IF (firstchar = SOH) AND
( (Wxmode AND (prevchar = SYN)) OR (NOT Wxmode) ) THEN
BEGIN {process packet}
prevchar := -1;
firstchar := -1;
sectcurr := dlecgetc(15);
{ writeln(trfile,'sectcurr=',sectcurr:4);}
sectcomp := dlecgetc(15);
IF sectcurr = (sectcomp XOR 255) THEN
BEGIN {sequence versus compl good}
IF sectcurr = ((sectnum+1) AND 255) THEN
BEGIN {in sequence}
crcval := 0;
checksum := 0;
j := 1;
REPEAT
firstchar := dlecgetc(15);
IF firstchar >= 0 THEN
BEGIN
IF j < 129 THEN
dbuffer[bufcurr, j] := firstchar;
IF Crcmode THEN
{updcrc(firstchar)} {3.04}
crcval := Crctab[hi(crcval) xor firstchar] xor (lo(crcval) shl 8)
ELSE
checksum := (checksum AND 255)+firstchar;
INC(j);
END;
UNTIL (j > Packetln) OR (firstchar < 0);
IF j > Packetln THEN {good packet length}
BEGIN
IF (Crcmode AND (crcval = 0) OR
(NOT Crcmode AND ((checksum SHR 1) = firstchar)))
THEN
BEGIN {good crc/checksum}
firstchar := -1; {make sure this byte not used
for start of packet } errors := 0;
sectnum := sectcurr;
INC(blkcnt);
send(ACK);
IF Wxmode THEN send(sectcurr AND 3);
{ write(trfile,' ACK ');}
{ if Wxmode then write(trfile,(sectcurr and 3):1);}
Str(blkcnt:4, statstr);
trwindow(3, statstr);
IF errors <> 0 THEN
BEGIN
errors := 0;
trwindow(6, '0');
trwindow(5, ' ');
END;
INC(bufcurr);
IF bufcurr > bufnum THEN
BEGIN {Disk write routine}
bufcurr := 1;
(* --------------------------
IF wxmode AND pcjrmode THEN
BEGIN {can't overlap disk i/o and comm i/o.}
send(XOFF); {stop transmitter}
Delay(250); {give it a chance}
END;
----------------------------- *)
BlockWrite(blkfile, dbuffer, bufnum, bresult);
(* -------------------------
IF wxmode AND pcjrmode THEN
BEGIN
{Flush(blkfile);} {complete all i/o}
send(XON); {restart transmitter}
END;
--------------------------- *)
IF bresult <> bufnum THEN
BEGIN
trwindow(8, 'Disk write error');
GOTO Exit_recv_wcp; {3.04}
END;
END; {End of disk write routine}
END {good crc/checksum}
ELSE
BEGIN {bad crc/checksum}
trwindow(5, 'CRC/Checksum error');
Str((blkcnt+1):6, statstr);
trwindow(4, statstr);
errors := errors+1;
Str(errors:3, statstr);
trwindow(6, statstr);
toterr := toterr+1;
Dump; {purge;} {clear any garbage coming in}
send(NAK);
IF wxmode THEN
BEGIN
send(sectcurr AND 3);
lignore := maxwindow;
END;
{write(trfile,' NAK CRC ',(sectcurr and 3):1);}
END; {bad crc/checsum}
END {good packet length}
ELSE
BEGIN {bad packet length}
trwindow(5, 'Short block error.'); {Chd 3.01}
Str((blkcnt+1):6, statstr);
trwindow(4, statstr);
errors := errors+1;
Str(errors:3, statstr);
trwindow(6, statstr);
INC(toterr);
Dump; {purge;} {clear any garbage}
send(NAK);
IF wxmode THEN
BEGIN
send(sectcurr AND 3);
lignore := maxwindow;
END;
dump; {purge;} {clear any garbage}
{write(trfile,' NAK SHORT ',(sectcurr and 3):1);}
END; {bad packet length}
END {good block sequence number}
ELSE
BEGIN {invalid sequence number}
IF lignore <= 0 THEN {are we ignoring packets?}
BEGIN
trwindow(5, 'Out of sequence.'); {Chd 3.01}
Str((blkcnt+1):6, statstr);
trwindow(4, statstr);
INC(errors);
Str(errors:3, statstr);
trwindow(6, statstr);
INC(toterr);
dump; {purge;} {clear any garbage coming in}
send(NAK);
IF wxmode THEN
BEGIN
send((sectnum+1) AND 3);
lignore := Maxwindow;
END;
dump; {purge;} {clear any garbage coming in}
{write(trfile,' NAK SEQ ',((sectnum+1) and 3):1);}
END
ELSE
DEC(lignore); {3.04}
END; {invalid sequence number}
END {valid complement}
ELSE
BEGIN {invalid complement}
trwindow(5, 'Sequence complement error.'); {Chd 3.01}
Str((blkcnt+1):6, statstr);
trwindow(4, statstr);
INC(errors);
Str(errors:3, statstr);
trwindow(6, statstr);
INC(toterr);
dump; {purge;} {clear any garbage comming in}
send(NAK);
IF wxmode THEN
BEGIN
send((sectnum+1) AND 3);
lignore := Maxwindow;
END;
dump; {purge;} {clear any garbage comming in}
{write(trfile,' NAK CMP ',((sectnum + 1) and 3):1);}
END;{invalid complement}
END {process packet}
ELSE {not start of packet}
BEGIN
CASE prevchar OF
EOT : BEGIN
IF firstchar = EOT THEN
BEGIN
EotFlag := True;
send(ACK);
END;
END;
CAN : BEGIN
IF firstchar = CAN THEN
GOTO Exit_recv_wcp; {3.04}
END;
END;{Of case}
IF NOT EotFlag THEN
BEGIN
IF firstchar = EOT THEN
BEGIN
send(NAK); {first EOT received}
trwindow(5, ' First EOT received.'); {Chd 3.01}
END;
prevchar := firstchar;
firstchar := cgetc(15); {start of packet!!!!}
IF firstchar = -1 THEN
BEGIN
IF (prevchar = CAN) OR (prevchar = EOT) THEN
firstchar := prevchar {assume two have been received}
ELSE
BEGIN
trwindow(5, 'Timeout on start of packet.'); {Chd 3.01}
Str((blkcnt+1):6, statstr);
trwindow(4, statstr);
INC(errors);
Str(errors:3, statstr);
trwindow(6, statstr);
send(XON);
INC(toterr);
send(NAK);
IF wxmode THEN
BEGIN
send((sectnum+1) AND 3);
lignore := Maxwindow;
END;
{ write(trfile,' NAK TIM ',((sectnum+1) and 3):1);}
END;
END; {Timeout at start of packet}
IF KeyPressed THEN
BEGIN
UserKey := ORD(ReadKey);
IF UserKey = CAN THEN GOTO Exit_recv_wcp; {3.04}
END;
END;{end of not EotFlag}
END;{not start of packet}
END;{xmodem loop}
{If there are any xmodem packets left in dbuffer, we had best
write them out}
IF EotFlag AND (bufcurr > 1) THEN
BEGIN
DEC(bufcurr); { 3.04 }
trwindow(8, 'Writing final blocks.'); {Chd 3.01}
(* -------------------------
IF wxmode AND pcjrmode THEN
BEGIN {if unable to overlap
disk i/o and comm i/o.}
send(XOFF); {stop transmitter}
Delay(250); {give it a chance}
END;
--------------------------- *)
BlockWrite(Blkfile, dbuffer, bufcurr, bresult);
(* ----------------------------
IF wxmode AND pcjrmode THEN
BEGIN
{Flush(blkfile);} {complete all i/o}
send(XON); {restart transmitter}
END;
----------------------------- *)
IF bufcurr <> bresult THEN
BEGIN
trwindow(8, 'Disk write error at end of receive.'); {Chd 3.01}
EotFlag := False; {no longer a 'real' eot}
END;
END;
Exit_recv_wcp: { exit routine }
IF NOT Eotflag THEN
BEGIN
IF errors >= Maxerrs THEN
trwindow(8, 'Maximum errors exceeded.') {Chd 3.01}
ELSE
IF UserKey = CAN THEN
BEGIN
trwindow(5, '^X entered.'); {Chd 3.01}
REPEAT {3.04}
FOR i := 1 TO 6 DO send(CAN); {3.04a}
Purge; {3.04a}
UNTIL (cgetc(1) = -1); {3.04}
END;
IF firstchar = CAN THEN
trwindow(5, 'Cancel received.'); {Chd 3.01}
IF openflag THEN
BEGIN
{$I-} Close(blkfile) {$I+} ;
i := IOResult; {clear ioresult}
{$I-} Erase(blkfile); {$I+}
i := IOResult; {clear ioresult}
END;
END;
trwindow(8, 'Press any key to continue.');
REPEAT UNTIL KeyPressed;
trwindow(8, ' '); {Added 3.01}
junk := ReadKey;
trwindow(99,' ');
ClrScr; { clear the transfer window }
Window(1,25,80,25);
Gotoxy(19,1);
IF carrier THEN
Write('On-Line/Ready ')
ELSE
Write('Off-Line/Ready');
Window(1,1,80,24);
dbits := db;
parity := p;
stop_bits := sb;
{close(trfile);}
{update_uart;}
END;{recv_wcp}
PROCEDURE send_wcp;
LABEL Exit_send_wcp,TransMit; {3.04}
VAR
UserKey : Byte;
c, i, j, sectnum, errors : Integer;
tblks, sblks, ackblks, rblks : Integer; {total, sent, ack'd blocks}
twindow, awindow : Integer; {transmission window}
bresult, nblks, prevchar : Integer;
bflag, canflag, xpause : Boolean;
extend : Boolean;
blkfile : FILE;
statstr : bigstring;
xblk, ackseq : Integer;
trfile : Text;
PROCEDURE checkack(tlimit : Integer);
VAR inchar : Integer;
BEGIN
REPEAT {until no more data & timelimit}
inchar := cgetc(0);
IF inchar <> -1 THEN
BEGIN {got a character}
IF wxmode THEN {wxmodem}
BEGIN
{write(trfile,inchar:4);}
CASE inchar OF
XOFF : BEGIN
xpause := True;
txwindow(8, 'Received - waiting.'); {Chd 3.01}
END;
XON : BEGIN
xpause := False;
txwindow(8, 'No');
END;
ACK, NAK, CAN : prevchar := inchar; {save ACK/NAK/CAN}
0..3 : BEGIN {valid ACK/NAK sequence number}
CASE prevchar OF
ACK : BEGIN
ackseq := inchar-(ackblks AND twindow);
IF ackseq <= 0 THEN
ackseq := ackseq+maxwindow;
nblks := ackblks+ackseq;
IF nblks <= sblks THEN
BEGIN
ackblks := nblks;
Str(ackblks:4, statstr);
txwindow(6, statstr);
IF errors <> 0 THEN
BEGIN
errors := 0;
txwindow(10, '0');
END;
END;
{ writeln(trfile,' ACK ',inchar:2,ackblks:5);}
prevchar := -1;
END; {case ACK}
NAK : BEGIN
ackseq := inchar-(ackblks AND twindow);
IF ackseq <= 0 THEN
ackseq := ackseq+maxwindow;
nblks := ackblks+ackseq;
IF nblks <= sblks THEN
BEGIN
sblks := nblks-1;
IF (sblks-ackblks) <= 2 THEN
ackblks := sblks;
Str(nblks:4, statstr);
txwindow(7, statstr);
Str(sblks:4, statstr);
txwindow(5, statstr);
INC(errors);
Str(errors:3, statstr);
txwindow(10, statstr);
END
ELSE
BEGIN
GoToXY(3, 12);
{ClrEol;}
WriteLn('Invalid NAK seq ', nblks:4, ackseq:4, inchar:3);
END;
{writeln(0tile,' NAK ',inchar:2,ackblks:5,sblks:5);}
prevchar := -1;
END; {case NAK}
CAN : BEGIN
IF inchar = CAN THEN canflag := True;
END;
END; {of case prevchar}
END; {case 0..3}
ELSE{of case inchar}
prevchar := -1; {inchar not XON/XOFF/ACK/NAK/CAN/0/1/2/3}
END;{of case inchar}
END{wxmodem mode}
ELSE
BEGIN {regular xmodem}
CASE inchar OF
ACK : BEGIN
ackblks := ackblks+1;
errors := 0;
END;
NAK : BEGIN
DEC(sblks); {3.04}
INC(errors); {3.04}
END;
CAN : BEGIN
IF prevchar = CAN THEN canflag := True;
prevchar := CAN;
END;
ELSE prevchar := inchar;
END; {end of case inchar}
END; {regular xmodem}
END {end of got a character}
ELSE {no incoming data, inchar=-1}
BEGIN
IF tlimit > 0 THEN
BEGIN
Delay(1);
DEC(tlimit); {3.04}
END;
END; {end no incoming data}
IF KeyPressed THEN
BEGIN
UserKey := ORD(ReadKey);
IF UserKey = CAN THEN
BEGIN
canflag := True;
tlimit := 0; {force end of repeat}
inchar := -1; { " " " " }
xpause := False;
dump; {purge;}
END;
END; {end of keypressed}
UNTIL (tlimit <= 0) AND (inchar = -1); {repeat until nothing left}
END; {of procedure checkack}
PROCEDURE dlesend(c : Integer);
VAR j : Integer;
BEGIN
IF wxmode THEN
BEGIN
IF Buffer_Count > 0 THEN {if there is any incoming data}
checkack(0);
WHILE xpause DO {X-Off received .. better wait}
BEGIN
j := 0;
REPEAT
checkack(0);
INC(j);
Delay(1);
UNTIL ((xpause = False) OR (j = 10000));
IF xpause THEN {but not forever}
BEGIN
txwindow(8, 'No - Timed Out.'); {Chd 3.01}
xpause := False;
END;
END;
CASE c OF
SYN, XON, XOFF, DLE : BEGIN
send(DLE);
send(c XOR 64);
END;
ELSE send(c);
END;{case}
END
ELSE send(c); {regular xmodem}
END;
BEGIN
Gotoxy(3,2); Write('SEND WXMODEM');
SaveCommStatus;
openflag := False;
{assign(trfile,'trace');}
{rewrite(trfile);}
DoBorder(1,3,80,8);
REPEAT
Gotoxy(3,2);
Write('Enter upload filename <cr> to abort:'); {Chd 3.04}
ReadLn(fname);
supcase(fname);
IF Length(fname) > 0 THEN
BEGIN
bflag := exists(fname);
IF NOT bflag THEN
BEGIN
Gotoxy(3,4);
Write('Could not open file: ', fname); {Chd 3.01}
Gotoxy(3,5);
Write('(Spelling or drive designation wrong?)');
END;
END;
UNTIL bflag OR (Length(fname) = 0);
BEGIN ClrScr; Window(1,1,80,24); END;
IF Length(fname) = 0 THEN GOTO Exit_send_wcp;
Assign(Blkfile, fname);
{$I-} Reset(Blkfile); {$I+}
IF IOResult <> 0 THEN GOTO Exit_send_wcp;
openflag := True;
txwindow(1, fname);
tblks := Trunc(LongFileSize(Blkfile));
Str((tblks)*22.3333333/speed:6:2, statstr);
txwindow(3, statstr);
Str(tblks:4, statstr);
txwindow(4, statstr);
txwindow(12, 'Press ^X to abort transfer.'); {Chd 3.01}
prevchar := -1;
sblks := 0; {sent blks}
ackblks := 0; {ack'd blocks}
rblks := 0; {highest read block}
errors := 0;
canflag := False; {not cancelled yet}
xpause := False;
UserKey := 0;
{Xmodem transmit protocol initialization}
i := 0;
REPEAT
c := cgetc(1);
IF c <> -1 THEN
BEGIN {we got a character!}
INC(i); {one of our 10 characters }
CASE c OF
NAK : BEGIN {Checksum Xmodem}
crcmode := False;
wxmode := False;
twindow := 0;
txwindow(2, 'Checksum Xmodem Send.'); {Chd 3.01}
GOTO TransMit; {3.04}
END;
CHARC : BEGIN {CRC Xmodem}
crcmode := True;
wxmode := False;
twindow := 0;
txwindow(2, 'CRC Xmodem Send.') {Chd 3.01};
GOTO TransMit; {3.04}
END;
CHARW : BEGIN {WXmodem}
crcmode := True;
wxmode := True;
twindow := Maxwindow-1;
txwindow(2, 'WXmodem Send.'); {Chd 3.01}
Str(Maxwindow:1, statstr);
txwindow(9, statstr);
GOTO TransMit; {3.04}
END;
CAN : BEGIN {Cancel request received}
IF canflag THEN
GOTO Exit_send_wcp
ELSE
canflag := True;
END;
END; {of case c}
END;{got a character}
IF KeyPressed THEN UserKey := ORD(ReadKey);
UNTIL (i > 10) OR (UserKey = CAN);
IF UserKey = CAN THEN GOTO Exit_send_wcp;
UserKey := 0;
txwindow(10, 'Could not start: cancelled.'); {Chd 3.01}
dump; {purge;}
GOTO Exit_send_wcp;
TransMit: {let's send the file!}
awindow := twindow;
errors := 0;
{Xmodem packet level loop}
WHILE (ackblks < tblks) AND (errors <= MAXERRS) DO
BEGIN
i := 0;
WHILE (sblks-ackblks) > awindow DO {is the ack window open?}
BEGIN {no, so wait for ack/nak}
INC(i);
IF i <= 1 THEN
BEGIN
Str((awindow+1):1, statstr);
txwindow(9, Concat(statstr, ' Closed.')); {Chd 3.01}
END;
checkack(50); {50*2400 = 120 seconds +}
IF canflag THEN GOTO Exit_send_wcp;
IF KeyPressed THEN
BEGIN
UserKey := ORD(ReadKey);
IF UserKey = CAN THEN GOTO Exit_send_wcp;
END;
IF i > 2400 THEN
BEGIN
txwindow(11, 'Timeout for ack.'); {Chd 3.01}
sblks := ackblks+1;
IF sblks > tblks THEN GOTO Exit_send_wcp;
END;
IF (sblks-ackblks) <= awindow THEN
BEGIN
Str((awindow+1):1, statstr);
txwindow(9, statstr);
END;
END;{window closed}
IF sblks < tblks THEN {is there anything left?}
BEGIN
awindow := twindow; {ack window is transmit window}
{disk read routine}
INC(sblks);
xblk := sblks;
WHILE (xblk > rblks) OR (xblk <= (rblks-bufnum)) DO
BEGIN
IF xblk < (rblks-bufnum) THEN {if we got nak'd back}
BEGIN
Seek(blkfile, (xblk-1));
END;
BlockRead(blkfile, dbuffer, bufnum, bresult);
rblks := xblk+bufnum-1; {note rblks must go past eof}
END; {end of disk read routine}
j := bufnum-rblks+xblk; {index of next packet}
crcval := 0;
checksum := 0;
Str(xblk:4, statstr);
txwindow(5, statstr);
IF wxmode THEN
BEGIN
WHILE xpause DO
BEGIN
checkack(15);
xpause := False;
txwindow(8, 'No');
END;
send(SYN);
END;
dlesend(SOH);
dlesend(xblk AND 255); {block sequence}
dlesend((xblk AND 255) XOR 255); {complement sequence}
FOR i := 1 TO 128 DO { main send loop is here }
BEGIN
c := dbuffer[j,i];
IF crcmode THEN
{updcrc(c)}
crcval := Crctab[hi(crcval) XOR c] XOR (lo(crcval) SHL 8)
ELSE
checksum := (checksum+c) AND 255;
dlesend(c);
END;
IF crcmode THEN { here we send the CRC or checksum }
BEGIN
dlesend(Hi(crcval)); dlesend(Lo(crcval));
END
ELSE
send(checksum);
IF canflag THEN GOTO Exit_send_wcp;
{writeln(trfile,'SENT ',sblks:5,xblk:5);}
END {something to send}
ELSE
BEGIN {nothing else to send}
IF wxmode THEN
BEGIN
awindow := sblks-ackblks-1; {wait for final acks}
Str(awindow:1, statstr);
txwindow(9, Concat(statstr, ' -- Closing'));
END;
END;
END;{xmodem send routine}
REPEAT {end of transmission}
send(EOT);
UserKey := 0;
REPEAT
c := cgetc(15);
IF keypressed THEN UserKey := ORD(ReadKey);
UNTIL (c <> -1) OR (UserKey = CAN);
IF UserKey = CAN THEN GOTO Exit_send_wcp;
IF c = NAK THEN
BEGIN
INC(errors);
Delay(250);
END;
UNTIL (c = ACK) OR (errors = MAXERRS);
IF errors = MAXERRS THEN
txwindow(11, 'ACK not received at EOT.'); {Chd 3.01}
Exit_send_wcp:
{ close(trfile);}
IF openflag THEN
BEGIN
{$I-} Close(blkfile); {$I+}
i := IOResult;
END;
IF ((UserKey = CAN) OR canflag) AND (Length(fname) > 0) THEN
BEGIN
txwindow(11, 'Canceled - at your request.'); {Chd 3.01}
REPEAT
send(CAN); send(CAN);
dump; {purge;}
UNTIL cgetc(1) = -1;
END;
txwindow(12, 'Press any key to continue.'); {Chd 3.01}
REPEAT UNTIL (KeyPressed);
txwindow(12, ' '); {Added 3.01}
junk := ReadKey;
txwindow(99, ' ');
Window(1,25,80,25);
Gotoxy(19,1);
IF carrier THEN
Write('On-Line/Ready ')
ELSE
Write('Off-Line/Ready');
Window(1,1,80,24);
dbits := db;
parity := p;
stop_bits := sb;
{update_uart;}
END;{send_wcp}
{$R+,S+}