home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
TP-Z
/
TPZ.PAS
next >
Wrap
Pascal/Delphi Source File
|
1988-09-18
|
50KB
|
1,883 lines
UNIT TPZ;
INTERFACE
USES Crt, Dos, TPZasync, TPZVideo, TPZFiles, TPZunix, TPZcrc;
FUNCTION Zmodem_Receive(path: STRING; comport: WORD; baudrate: LONGINT): BOOLEAN;
FUNCTION Zmodem_Send(pathname: STRING; lastfile: BOOLEAN; comport: WORD; baudrate: LONGINT): BOOLEAN;
IMPLEMENTATION
CONST
TPZVER = 'TPZ [Zmodem] 2.1ß';
ZBUFSIZE = 1024;
zport: WORD = 1;
zbaud: LONGINT = 0;
TYPE
hdrtype = ARRAY[0..3] OF BYTE;
buftype = ARRAY[0..1023] OF BYTE;
CONST
ZPAD = 42; { '*' }
ZDLE = 24; { ^X }
ZDLEE = 88;
ZBIN = 65; { 'A' }
ZHEX = 66; { 'B' }
ZBIN32 = 67;{ 'C' }
ZRQINIT = 0;
ZRINIT = 1;
ZSINIT = 2;
ZACK = 3;
ZFILE = 4;
ZSKIP = 5;
ZNAK = 6;
ZABORT = 7;
ZFIN = 8;
ZRPOS = 9;
ZDATA = 10;
ZEOF = 11;
ZFERR = 12;
ZCRC = 13;
ZCHALLENGE = 14;
ZCOMPL = 15;
ZCAN = 16;
ZFREECNT = 17;
ZCOMMAND = 18;
ZSTDERR = 19;
ZCRCE = 104; { 'h' }
ZCRCG = 105; { 'i' }
ZCRCQ = 106; { 'j' }
ZCRCW = 107; { 'k' }
ZRUB0 = 108; { 'l' }
ZRUB1 = 109; { 'm' }
ZOK = 0;
ZERROR = -1;
ZTIMEOUT = -2;
RCDO = -3;
FUBAR = -4;
GOTOR = 256;
GOTCRCE = 360; { 'h' OR 256 }
GOTCRCG = 361; { 'i' " " }
GOTCRCQ = 362; { 'j' " " }
GOTCRCW = 363; { 'k' " " }
GOTCAN = 272; { CAN OR " }
{ xmodem paramaters }
CONST
ENQ = 5;
CAN = 24;
XOFF = 19;
XON = 17;
SOH = 1;
STX = 2;
EOT = 4;
ACK = 6;
NAK = 21;
CPMEOF = 26;
{ byte positions }
CONST
ZF0 = 3;
ZF1 = 2;
ZF2 = 1;
ZF3 = 0;
ZP0 = 0;
ZP1 = 1;
ZP2 = 2;
ZP3 = 3;
{ bit masks for ZRINIT }
CONST
CANFDX = 1; { can handle full-duplex (yes for PC's)}
CANOVIO = 2; { can overlay disk and serial I/O (ditto) }
CANBRK = 4; { can send a break - True but superfluous }
CANCRY = 8; { can encrypt/decrypt - not defined yet }
CANLZW = 16; { can LZ compress - not defined yet }
CANFC32 = 32; { can use 32 bit crc frame checks - true }
ESCALL = 64; { escapes all control chars. NOT implemented }
ESC8 = 128; { escapes the 8th bit. NOT implemented }
{ bit masks for ZSINIT }
CONST
TESCCTL = 64;
TESC8 = 128;
{ paramaters for ZFILE }
CONST
{ ZF0 }
ZCBIN = 1;
ZCNL = 2;
ZCRESUM = 3;
{ ZF1 }
ZMNEW = 1; {I haven't implemented these as of yet - most are}
ZMCRC = 2; {superfluous on a BBS - Would be nice from a comm}
ZMAPND = 3; {programs' point of view however }
ZMCLOB = 4;
ZMSPARS = 5;
ZMDIFF = 6;
ZMPROT = 7;
{ ZF2 }
ZTLZW = 1; {encryption, compression and funny file handling }
ZTCRYPT = 2; {flags - My docs (03/88) from OMEN say these have}
ZTRLE = 3; {not been defined yet }
{ ZF3 }
ZCACK1 = 1; {God only knows... }
VAR
rxpos: LONGINT; {file position received from Z_GetHeader}
rxhdr: hdrtype; {receive header var}
rxtimeout,
rxtype,
rxframeind: INTEGER;
attn: buftype;
secbuf: buftype;
fname: STRING;
fmode: INTEGER;
ftime,
fsize: LONGINT;
usecrc32: BOOLEAN;
zcps, zerrors: WORD;
txpos: LONGINT;
txhdr: hdrtype;
ztime: LONGINT;
CONST
lastsent: BYTE = 0;
FUNCTION Z_SetTimer: LONGINT;
VAR
l: LONGINT;
h,m,s,x: WORD;
BEGIN
GetTime(h,m,s,x);
l := LONGINT(h) * 3600;
l := l + LONGINT(m) * 60;
l := l + LONGINT(s);
Z_SetTimer := l
END;
FUNCTION Z_FileCRC32(VAR f: FILE): LONGINT;
VAR
fbuf: buftype;
crc: LONGINT;
bread, n: INTEGER;
BEGIN {$I-}
crc := $FFFFFFFF;
Seek(f,0);
IF (IOresult <> 0) THEN
{null};
REPEAT
BlockRead(f,fbuf,ZBUFSIZE,bread);
FOR n := 0 TO (bread - 1) DO
crc := UpdC32(fbuf[n],crc)
UNTIL (bread < ZBUFSIZE) OR (IOresult <> 0);
Seek(f,0);
IF (IOresult <> 0) THEN
{null};
Z_FileCRC32 := crc
END; {$I+}
FUNCTION Z_GetByte(tenths: INTEGER): INTEGER;
(* Reads a byte from the modem - Returns RCDO if *)
(* no carrier, or ZTIMEOUT if nothing received *)
(* within 'tenths' of a second. *)
VAR
n: INTEGER;
BEGIN
REPEAT
IF (NOT Z_Carrier) THEN
BEGIN
Z_GetByte := RCDO; { nobody to talk to }
Exit
END;
IF (Z_CharAvail) THEN
BEGIN
Z_GetByte := Z_ReceiveByte; { got character }
Exit
END;
Dec(tenths); { dec. the count }
Delay(100) { pause 1/10th sec. }
UNTIL (tenths <= 0);
Z_GetByte := ZTIMEOUT { timed out }
END;
FUNCTION Z_qk_read: INTEGER;
(* Just like Z_GetByte, but timeout value is in *)
(* global var rxtimeout. *)
BEGIN
Z_qk_read := Z_GetByte(rxtimeout)
END;
FUNCTION Z_TimedRead: INTEGER;
(* A Z_qk_read, that strips parity and *)
(* ignores XON/XOFF characters. *)
VAR
done: BOOLEAN;
c: INTEGER;
BEGIN
done := FALSE;
REPEAT
c := Z_qk_read AND $FF7F { strip parity }
UNTIL (c < 0) OR (NOT (Lo(c) IN [17,19])); { wait for other than XON/XOFF }
Z_TimedRead := c
END;
PROCEDURE Z_SendCan;
(* Send a zmodem CANcel sequence to the other guy *)
(* 8 CANs and 8 backspaces *)
VAR
n: BYTE;
BEGIN
Z_ClearOutbound; { spare them the junk }
FOR n := 1 To 8 DO
BEGIN
Z_SendByte(CAN);
Delay(100) { the pause seems to make reception of the sequence }
END; { more reliable }
FOR n := 1 TO 10 DO
Z_SendByte(8)
END;
PROCEDURE Z_PutString(VAR p: buftype);
(* Outputs an ASCII-Z type string (null terminated) *)
(* Processes meta characters 221 (send break) and *)
(* 222 (2 second delay). *)
VAR
n: INTEGER;
BEGIN
n := 0;
WHILE (n < ZBUFSIZE) AND (p[n] <> 0) DO
BEGIN
CASE p[n] OF
221 : Z_SendBreak;
222 : Delay(2000)
ELSE
Z_SendByte(p[n])
END;
Inc(n)
END
END;
PROCEDURE Z_PutHex(b: BYTE);
(* Output a byte as two hex digits (in ASCII) *)
(* Uses lower case to avoid confusion with *)
(* escaped control characters. *)
CONST
hex: ARRAY[0..15] OF CHAR = '0123456789abcdef';
BEGIN
Z_SendByte(Ord(hex[b SHR 4])); { high nybble }
Z_SendByte(Ord(hex[b AND $0F])) { low nybble }
END;
PROCEDURE Z_SendHexHeader(htype: BYTE; VAR hdr: hdrtype);
(* Sends a zmodem hex type header *)
VAR
crc: WORD;
n, i: INTEGER;
BEGIN
Z_SendByte(ZPAD); { '*' }
Z_SendByte(ZPAD); { '*' }
Z_SendByte(ZDLE); { 24 }
Z_SendByte(ZHEX); { 'B' }
Z_PutHex(htype);
crc := UpdCrc(htype,0);
FOR n := 0 TO 3 DO
BEGIN
Z_PutHex(hdr[n]);
crc := UpdCrc(hdr[n],crc)
END;
crc := UpdCrc(0,crc);
crc := UpdCrc(0,crc);
Z_PutHex(Lo(crc SHR 8));
Z_PutHex(Lo(crc));
Z_SendByte(13); { make it readable to the other end }
Z_SendByte(10); { just in case }
IF (htype <> ZFIN) AND (htype <> ZACK) THEN
Z_SendByte(17); { Prophylactic XON to assure flow }
IF (NOT Z_Carrier) THEN
Z_ClearOutbound
END;
FUNCTION Z_PullLongFromHeader(VAR hdr: hdrtype): LONGINT;
(* Stuffs a longint into a header variable - N.B. - bytes are REVERSED! *)
VAR
l: LONGINT;
BEGIN
l := hdr[ZP3]; { hard coded for efficiency }
l := (l SHL 8) OR hdr[ZP2];
l := (l SHL 8) OR hdr[ZP1];
l := (l SHL 8) OR hdr[ZP0];
Z_PullLongFromHeader := l
END;
PROCEDURE Z_PutLongIntoHeader(l: LONGINT);
(* Reverse of above *)
BEGIN
txhdr[ZP0] := BYTE(l);
txhdr[ZP1] := BYTE(l SHR 8);
txhdr[ZP2] := BYTE(l SHR 16);
txhdr[ZP3] := BYTE(l SHR 24)
END;
FUNCTION Z_GetZDL: INTEGER;
(* Gets a byte and processes for ZMODEM escaping or CANcel sequence *)
VAR
c, d: INTEGER;
BEGIN
IF (NOT Z_Carrier) THEN
BEGIN
Z_GetZDL := RCDO;
Exit
END;
c := Z_qk_read;
IF (c <> ZDLE) THEN
BEGIN
Z_GetZDL := c;
Exit
END; {got ZDLE or 1st CAN}
c := Z_qk_read;
IF (c = CAN) THEN {got 2nd CAN}
BEGIN
c := Z_qk_read;
IF (c = CAN) THEN {got 3rd CAN}
BEGIN
c := Z_qk_read;
IF (c = CAN) THEN {got 4th CAN}
c := Z_qk_read
END
END;
{ Flags set in high byte }
CASE c OF
CAN: Z_GetZDL := GOTCAN; {got 5th CAN}
ZCRCE, {got a frame end marker}
ZCRCG,
ZCRCQ,
ZCRCW: Z_GetZDL := (c OR GOTOR);
ZRUB0: Z_GetZDL := $007F; {got an ASCII DELete}
ZRUB1: Z_GetZDL := $00FF {any parity }
ELSE
BEGIN
IF (c < 0) THEN
Z_GetZDL := c
ELSE IF ((c AND $60) = $40) THEN {make sure it was a valid escape}
Z_GetZDL := c XOR $40
ELSE
Z_GetZDL := ZERROR
END
END
END;
FUNCTION Z_GetHex: INTEGER;
(* Get a byte that has been received as two ASCII hex digits *)
VAR
c, n: INTEGER;
BEGIN
n := Z_TimedRead;
IF (n < 0) THEN
BEGIN
Z_GetHex := n;
Exit
END;
n := n - $30; {build the high nybble}
IF (n > 9) THEN
n := n - 39;
IF (n AND $FFF0 <> 0) THEN
BEGIN
Z_GetHex := ZERROR;
Exit
END;
c := Z_TimedRead;
IF (c < 0) THEN
BEGIN
Z_GetHex := c;
Exit
END;
c := c - $30; {now the low nybble}
IF (c > 9) THEN
c := c - 39;
IF (c AND $FFF0 <> 0) THEN
BEGIN
Z_GetHex := ZERROR;
Exit
END;
Z_GetHex := (n SHL 4) OR c {Insert tab 'A' in slot 'B'...}
END;
FUNCTION Z_GetHexHeader(VAR hdr: hdrtype): INTEGER;
(* Receives a zmodem hex type header *)
VAR
crc: WORD;
c, n: INTEGER;
BEGIN
c := Z_GetHex;
IF (c < 0) THEN
BEGIN
Z_GetHexHeader := c;
Exit
END;
rxtype := c; {get the type of header}
crc := UpdCrc(rxtype,0);
FOR n := 0 To 3 DO {get the 4 bytes}
BEGIN
c := Z_GetHex;
IF (c < 0) THEN
BEGIN
Z_GetHexHeader := c;
Exit
END;
hdr[n] := Lo(c);
crc := UpdCrc(Lo(c),crc)
END;
c := Z_GetHex;
IF (c < 0) THEN
BEGIN
Z_GetHexHeader := c;
Exit
END;
crc := UpdCrc(Lo(c),crc);
c := Z_GetHex;
IF (c < 0) THEN
BEGIN
Z_GetHexHeader := c;
Exit
END;
crc := UpdCrc(Lo(c),crc); {check the CRC}
IF (crc <> 0) THEN
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
Z_GetHexHeader := ZERROR;
Exit
END;
IF (Z_GetByte(1) = 13) THEN {throw away CR/LF}
c := Z_GetByte(1);
Z_GetHexHeader := rxtype
END;
FUNCTION Z_GetBinaryHeader(VAR hdr: hdrtype): INTEGER;
(* Same as above, but binary with 16 bit CRC *)
VAR
crc: WORD;
c, n: INTEGER;
BEGIN
c := Z_GetZDL;
IF (c < 0) THEN
BEGIN
Z_GetBinaryHeader := c;
Exit
END;
rxtype := c;
crc := UpdCrc(rxtype,0);
FOR n := 0 To 3 DO
BEGIN
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
Z_GetBinaryHeader := c;
Exit
END;
hdr[n] := Lo(c);
crc := UpdCrc(Lo(c),crc)
END;
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
Z_GetBinaryHeader := c;
Exit
END;
crc := UpdCrc(Lo(c),crc);
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
Z_GetBinaryHeader := c;
Exit
END;
crc := UpdCrc(Lo(c),crc);
IF (crc <> 0) THEN
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
Exit
END;
Z_GetBinaryHeader := rxtype
END;
FUNCTION Z_GetBinaryHead32(VAR hdr: hdrtype): INTEGER;
(* Same as above but with 32 bit CRC *)
VAR
crc: LONGINT;
c, n: INTEGER;
BEGIN
c := Z_GetZDL;
IF (c < 0) THEN
BEGIN
Z_GetBinaryHead32 := c;
Exit
END;
rxtype := c;
crc := UpdC32(rxtype,$FFFFFFFF);
FOR n := 0 To 3 DO
BEGIN
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
Z_GetBinaryHead32 := c;
Exit
END;
hdr[n] := Lo(c);
crc := UpdC32(Lo(c),crc)
END;
FOR n := 0 To 3 DO
BEGIN
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
Z_GetBinaryHead32 := c;
Exit
END;
crc := UpdC32(Lo(c),crc)
END;
IF (crc <> $DEBB20E3) THEN {this is the polynomial value}
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
Z_GetBinaryHead32 := ZERROR;
Exit
END;
Z_GetBinaryHead32 := rxtype
END;
FUNCTION Z_GetHeader(VAR hdr: hdrtype): INTEGER;
(* Use this routine to get a header - it will figure out *)
(* what type it is getting (hex, bin16 or bin32) and call *)
(* the appropriate routine. *)
LABEL
gotcan, again, agn2, splat, done; {sorry, but it's actually eisier to}
VAR {follow, and lots more efficient }
c, n, cancount: INTEGER; {this way... }
BEGIN
n := zbaud * 2; {A guess at the # of garbage characters}
cancount := 5; {to expect. }
usecrc32 := FALSE; {assume 16 bit until proven otherwise }
again:
IF (KeyPressed) THEN {check for operator panic}
IF (ReadKey = #27) THEN {in the form of ESCape }
BEGIN
Z_SendCan; {tell the other end, }
Z_message('Cancelled from keyboard'); {the operator, }
Z_GetHeader := ZCAN; {and the rest of the }
Exit {routines to forget it.}
END;
rxframeind := 0;
rxtype := 0;
c := Z_TimedRead;
CASE c OF
ZPAD: {we want this! - all headers begin with '*'.} ;
RCDO,
ZTIMEOUT: GOTO done;
CAN: BEGIN
gotcan:
Dec(cancount);
IF (cancount < 0) THEN
BEGIN
c := ZCAN;
GOTO done
END;
c := Z_GetByte(1);
CASE c OF
ZTIMEOUT: GOTO again;
ZCRCW: BEGIN
c := ZERROR;
GOTO done
END;
RCDO: GOTO done;
CAN: BEGIN
Dec(cancount);
IF (cancount < 0) THEN
BEGIN
c := ZCAN;
GOTO done
END;
GOTO again
END
ELSE
{fallthru}
END {case}
END {can}
ELSE
agn2: BEGIN
Dec(n);
IF (n < 0) THEN
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
Z_message('Header is FUBAR');
Z_GetHeader := ZERROR;
Exit
END;
IF (c <> CAN) THEN
cancount := 5;
GOTO again
END
END; {only falls thru if ZPAD - anything else is trash}
cancount := 5;
splat:
c := Z_TimedRead;
CASE c OF
ZDLE: {this is what we want!} ;
ZPAD: GOTO splat; {junk or second '*' of a hex header}
RCDO,
ZTIMEOUT: GOTO done
ELSE
GOTO agn2
END; {only falls thru if ZDLE}
c := Z_TimedRead;
CASE c OF
ZBIN32: BEGIN
rxframeind := ZBIN32; {using 32 bit CRC}
c := Z_GetBinaryHead32(hdr)
END;
ZBIN: BEGIN
rxframeind := ZBIN; {bin with 16 bit CRC}
c := Z_GetBinaryHeader(hdr)
END;
ZHEX: BEGIN
rxframeind := ZHEX; {hex}
c := Z_GetHexHeader(hdr)
END;
CAN: GOTO gotcan;
RCDO,
ZTIMEOUT: GOTO done
ELSE
GOTO agn2
END; {only falls thru if we got ZBIN, ZBIN32 or ZHEX}
rxpos := Z_PullLongFromHeader(hdr); {set rxpos just in case this}
done: {header has file position }
Z_GetHeader := c {info (i.e.: ZRPOS, etc. )}
END;
(***************************************************)
(* RECEIVE FILE ROUTINES *)
(***************************************************)
CONST
ZATTNLEN = 32; {max length of attention string}
lastwritten: BYTE = 0;
VAR
t: LONGINT;
rzbatch: BOOLEAN;
outfile: FILE; {this is the file}
tryzhdrtype: BYTE;
rxcount: INTEGER;
filestart: LONGINT;
isbinary, eofseen: BOOLEAN;
zconv: BYTE;
zrxpath: STRING;
FUNCTION RZ_ReceiveDa32(VAR buf: buftype; blength: INTEGER): INTEGER;
(* Get a 32 bit CRC data block *)
LABEL
crcfoo;
VAR
c, d, n: INTEGER;
crc: LONGINT;
done: boolean;
BEGIN
usecrc32 := TRUE;
crc := $FFFFFFFF;
rxcount := 0;
done := FALSE;
REPEAT
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
crcfoo: CASE c OF
GOTCRCE,
GOTCRCG,
GOTCRCQ,
GOTCRCW: BEGIN
d := c;
crc := UpdC32(Lo(c),crc);
FOR n := 0 TO 3 DO
BEGIN
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
GOTO crcfoo;
crc := UpdC32(Lo(c),crc)
END;
IF (crc <> $DEBB20E3) THEN
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
RZ_ReceiveDa32 := ZERROR
END
ELSE
RZ_ReceiveDa32 := d;
DONE := TRUE
END;
GOTCAN: BEGIN
RZ_ReceiveDa32 := ZCAN;
DONE := TRUE
END;
ZTIMEOUT: BEGIN
RZ_ReceiveDa32 := c;
DONE := TRUE
END;
RCDO: BEGIN
RZ_ReceiveDa32 := c;
done := TRUE
END
ELSE
BEGIN
Z_message('Debris');
Z_ClearInbound;
RZ_ReceiveDa32 := c;
DONE := TRUE
END
END
END;
IF (NOT done) THEN
BEGIN
Dec(blength);
IF (blength < 0) THEN
BEGIN
Z_message('Long packet');
RZ_ReceiveDa32 := ZERROR;
done := TRUE
END;
buf[INTEGER(rxcount)] := Lo(c);
Inc(rxcount);
crc := UpdC32(Lo(c),crc)
END
UNTIL done
END;
FUNCTION RZ_ReceiveData(VAR buf: buftype; blength: INTEGER): INTEGER;
(* get a 16 bit CRC data block *)
LABEL
crcfoo;
VAR
c, d: INTEGER;
crc: WORD;
done: boolean;
BEGIN
IF (rxframeind = ZBIN32) THEN
BEGIN
Z_ShowCheck(TRUE);
RZ_ReceiveData := RZ_ReceiveDa32(buf,blength);
Exit
END;
Z_ShowCheck(FALSE);
crc := 0;
rxcount := 0;
done := FALSE;
REPEAT
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
BEGIN
crcfoo: CASE c OF
GOTCRCE,
GOTCRCG,
GOTCRCQ,
GOTCRCW: BEGIN
d := c;
crc := UpdCrc(Lo(c),crc);
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
GOTO crcfoo;
crc := UpdCrc(Lo(c),crc);
c := Z_GetZDL;
IF (Hi(c) <> 0) THEN
GOTO crcfoo;
crc := UpdCrc(Lo(c),crc);
IF (crc <> 0) THEN
BEGIN
Inc(zerrors);
Z_Errors(zerrors);
RZ_ReceiveData := ZERROR;
done := TRUE
END;
RZ_ReceiveData := d;
DONE := TRUE
END;
GOTCAN: BEGIN
Z_Message('Got CANned');
RZ_ReceiveData := ZCAN;
DONE := TRUE
END;
ZTIMEOUT: BEGIN
RZ_ReceiveData := c;
DONE := TRUE
END;
RCDO: BEGIN
Z_Message('Lost carrier');
RZ_ReceiveData := c;
done := TRUE
END
ELSE
BEGIN
Z_message('Debris');
Z_ClearInbound;
RZ_ReceiveData := c;
DONE := TRUE
END
END
END;
IF (NOT done) THEN
BEGIN
Dec(blength);
IF (blength < 0) THEN
BEGIN
Z_message('Long packet');
RZ_ReceiveData := ZERROR;
done := TRUE
END;
buf[INTEGER(rxcount)] := Lo(c);
Inc(rxcount);
crc := UpdCrc(Lo(c),crc)
END
UNTIL done
END;
PROCEDURE RZ_AckBibi;
(* ACKnowledge the other ends request to terminate cleanly *)
VAR
n: INTEGER;
BEGIN
Z_PutLongIntoHeader(rxpos);
n := 4;
Z_ClearInbound;
REPEAT
Z_SendHexHeader(ZFIN,txhdr);
CASE Z_GetByte(20) OF
ZTIMEOUT,
RCDO: Exit;
79: BEGIN
IF (Z_GetByte(10) = 79) THEN
{null};
Z_ClearInbound;
Exit
END
ELSE
Z_ClearInbound;
Dec(n)
END
UNTIL (n <= 0)
END;
FUNCTION RZ_InitReceiver: INTEGER;
LABEL
again;
VAR
c, n, errors: INTEGER;
BEGIN
FillChar(attn,SizeOf(attn),0);
zerrors := 0;
FOR n := 10 DOWNTO 0 DO
BEGIN
IF (NOT Z_Carrier) THEN
BEGIN
Z_Message('Lost carrier');
RZ_InitReceiver := ZERROR;
Exit
END;
Z_PutLongIntoHeader(LONGINT(0));
txhdr[ZF0] := CANFDX OR CANOVIO OR CANFC32 OR CANBRK; {Full dplx, overlay I/O and CRC32}
Z_SendHexHeader(tryzhdrtype,txhdr);
IF (tryzhdrtype = ZSKIP) THEN
tryzhdrtype := ZRINIT;
again:
c := Z_GetHeader(rxhdr);
Z_Frame(c);
CASE c OF
ZFILE: BEGIN
zconv := rxhdr[ZF0];
tryzhdrtype := ZRINIT;
c := RZ_ReceiveData(secbuf,ZBUFSIZE);
Z_Frame(c);
IF (c = GOTCRCW) THEN
BEGIN
RZ_InitReceiver := ZFILE;
Exit
END;
Z_SendHexHeader(ZNAK,txhdr);
GOTO again
END;
ZSINIT: BEGIN
c := RZ_ReceiveData(attn,ZBUFSIZE);
Z_Frame(c);
IF (c = GOTCRCW) THEN
Z_SendHexHeader(ZACK,txhdr)
ELSE
Z_SendHexHeader(ZNAK,txhdr);
GOTO again
END;
ZFREECNT: BEGIN
Z_PutLongIntoHeader(DiskFree(0));
Z_SendHexHeader(ZACK,txhdr);
GOTO again
END;
ZCOMMAND: BEGIN
c := RZ_ReceiveData(secbuf,ZBUFSIZE);
Z_Frame(c);
IF (c = GOTCRCW) THEN
BEGIN
Z_PutLongIntoHeader(LONGINT(0));
REPEAT
Z_SendHexHeader(ZCOMPL,txhdr);
Inc(errors)
UNTIL (errors > 10) OR (Z_GetHeader(rxhdr) = ZFIN);
RZ_AckBibi;
RZ_InitReceiver := ZCOMPL;
Exit
END;
Z_SendHexHeader(ZNAK,txhdr);
GOTO again
END;
ZCOMPL,
ZFIN: BEGIN
RZ_InitReceiver := ZCOMPL;
Exit
END;
ZCAN,
RCDO: BEGIN
RZ_InitReceiver := c;
Exit
END
END
END;
Z_message('Timeout');
RZ_InitReceiver := ZERROR
END;
FUNCTION RZ_GetHeader: INTEGER;
VAR
e, p, n, i: INTEGER;
multiplier: LONGINT;
s: STRING;
ttime, tsize: LONGINT;
tname: STRING;
BEGIN
isbinary := TRUE; {Force the issue!}
fsize := LONGINT(0);
p := 0;
s := '';
WHILE (p < 255) AND (secbuf[p] <> 0) DO
BEGIN
s := s + UpCase(Chr(secbuf[p]));
Inc(p)
END;
Inc(p);
(* get rid of drive & path specifiers *)
WHILE (Pos(':',s) > 0) DO
Delete(s,1,Pos(':',s));
WHILE (Pos('\',s) > 0) DO
Delete(s,1,Pos('\',s));
fname := s;
(**** done with name ****)
fsize := LONGINT(0);
WHILE (p < ZBUFSIZE) AND (secbuf[p] <> $20) AND (secbuf[p] <> 0) DO
BEGIN
fsize := (fsize *10) + Ord(secbuf[p]) - $30;
Inc(p)
END;
Inc(p);
(**** done with size ****)
s := '';
WHILE (p < ZBUFSIZE) AND (secbuf[p] IN [$30..$37]) DO
BEGIN
s := s + Chr(secbuf[p]);
Inc(p)
END;
Inc(p);
ftime := Z_FromUnixDate(s);
(**** done with time ****)
IF (Z_FindFile(zrxpath+fname,tname,tsize,ttime)) THEN
BEGIN
IF (zconv = ZCRESUM) AND (fsize > tsize) THEN
BEGIN
filestart := tsize;
IF (NOT Z_OpenFile(outfile,zrxpath + fname)) THEN
BEGIN
Z_message('Error opening '+fname);
RZ_GetHeader := ZERROR;
Exit
END;
IF (NOT Z_SeekFile(outfile,tsize)) THEN
BEGIN
Z_Message('Error positioning file');
RZ_GetHeader := ZERROR;
Exit
END;
Z_Message('Recovering')
END
ELSE
BEGIN
Z_ShowName(fname);
Z_Message('File is already complete');
RZ_GetHeader := ZSKIP;
Exit
END
END
ELSE
BEGIN
filestart := 0;
IF (NOT Z_MakeFile(outfile,zrxpath + fname)) THEN
BEGIN
Z_message('Unable to create '+fname);
RZ_GetHeader := ZERROR;
Exit
END
END;
Z_ShowName(fname);
Z_ShowSize(fsize);
Z_ShowTransferTime(fsize,zbaud);
RZ_GetHeader := ZOK
END;
FUNCTION RZ_SaveToDisk(VAR rxbytes: LONGINT): INTEGER;
BEGIN
IF (KeyPressed) THEN
IF (ReadKey = #27) THEN
BEGIN
Z_message('Aborted from keyboard');
Z_SendCan;
RZ_SaveToDisk := ZERROR;
Exit
END;
IF (NOT Z_WriteFile(outfile,secbuf,rxcount)) THEN
BEGIN
Z_Message('Disk write error');
RZ_SaveToDisk := ZERROR
END
ELSE
RZ_SaveToDisk := ZOK;
rxbytes := rxbytes + rxcount
END;
FUNCTION RZ_ReceiveFile: INTEGER;
LABEL
err, nxthdr, moredata;
VAR
c, n: INTEGER;
rxbytes: LONGINT;
sptr: STRING;
done: BOOLEAN;
BEGIN
zerrors := 0;
done := FALSE;
eofseen := FALSE;
c := RZ_GetHeader;
IF (c <> ZOK) THEN
BEGIN
IF (c = ZSKIP) THEN
tryzhdrtype := ZSKIP;
RZ_ReceiveFile := c;
Exit
END;
c := ZOK;
n := 10;
rxbytes := filestart;
rxpos := filestart;
ztime := Z_SetTimer;
zcps := 0;
REPEAT
Z_PutLongIntoHeader(rxbytes);
Z_SendHexHeader(ZRPOS,txhdr);
nxthdr:
c := Z_GetHeader(rxhdr);
Z_Frame(c);
CASE c OF
ZDATA: BEGIN
IF (rxpos <> rxbytes) THEN
BEGIN
Dec(n);
Inc(zerrors);
Z_Errors(zerrors);
IF (n < 0) THEN
GOTO err;
Z_message('Bad position');
Z_PutString(attn)
END
ELSE
BEGIN
moredata:
c := RZ_ReceiveData(secbuf,ZBUFSIZE);
Z_Frame(c);
CASE c OF
ZCAN,
RCDO: GOTO err;
ZERROR: BEGIN
Dec(n);
Inc(zerrors);
Z_Errors(zerrors);
IF (n < 0) THEN
GOTO err;
Z_PutString(attn)
END;
ZTIMEOUT: BEGIN
Dec(n);
IF (n < 0) THEN
GOTO err
END;
GOTCRCW: BEGIN
n := 10;
c := RZ_SaveToDisk(rxbytes);
IF (c <> ZOK) THEN
BEGIN
RZ_ReceiveFile := c;
Exit
END;
Z_ShowLoc(rxbytes);
Z_PutLongIntoHeader(rxbytes);
Z_SendHexHeader(ZACK,txhdr);
GOTO nxthdr
END;
GOTCRCQ: BEGIN
n := 10;
c := RZ_SaveToDisk(rxbytes);
IF (c <> ZOK) THEN
BEGIN
RZ_ReceiveFile := c;
Exit
END;
Z_ShowLoc(rxbytes);
Z_PutLongIntoHeader(rxbytes);
Z_SendHexHeader(ZACK,txhdr);
GOTO moredata
END;
GOTCRCG: BEGIN
n := 10;
c := RZ_SaveToDisk(rxbytes);
IF (c <> ZOK) THEN
BEGIN
RZ_ReceiveFile := c;
Exit
END;
Z_ShowLoc(rxbytes);
GOTO moredata
END;
GOTCRCE: BEGIN
n := 10;
c := RZ_SaveToDisk(rxbytes);
IF (c <> ZOK) THEN
BEGIN
RZ_ReceiveFile := c;
Exit
END;
Z_ShowLoc(rxbytes);
GOTO nxthdr
END
END {case}
END
END; {case of ZDATA}
ZNAK,
ZTIMEOUT: BEGIN
Dec(n);
IF (n < 0) THEN
GOTO err;
Z_ShowLoc(rxbytes)
END;
ZFILE: BEGIN
c := RZ_ReceiveData(secbuf,ZBUFSIZE);
Z_Frame(c)
END;
ZEOF: IF (rxpos = rxbytes) THEN
BEGIN
RZ_ReceiveFile := c;
Exit
END
ELSE
GOTO nxthdr;
ZERROR: BEGIN
Dec(n);
IF (n < 0) THEN
GOTO err;
Z_ShowLoc(rxbytes);
Z_PutSTring(attn)
END
ELSE
BEGIN
c := ZERROR;
GOTO err
END
END {case}
UNTIL (NOT done);
err:
RZ_ReceiveFile := ZERROR
END;
FUNCTION RZ_ReceiveBatch: INTEGER;
VAR
s: STRING;
c: INTEGER;
done: BOOLEAN;
BEGIN
Z_Message('Receiving...');
done := FALSE;
WHILE (NOT done) DO
BEGIN
IF NOT (Z_Carrier) THEN
BEGIN
RZ_ReceiveBatch := ZERROR;
Exit
END;
c := RZ_ReceiveFile;
zcps := fsize DIV (Z_SetTimer - ztime);
Z_Frame(c);
Z_SetFTime(outfile,ftime);
Z_CloseFile(outfile);
Str(zcps:4,s);
Z_Message(s+' cps');
CASE c OF
ZEOF,
ZSKIP: BEGIN
c := RZ_InitReceiver;
Z_Frame(c);
CASE c OF
ZFILE: {null};
ZCOMPL: BEGIN
RZ_AckBibi;
RZ_ReceiveBatch := ZOK;
Exit
END;
ELSE
BEGIN
RZ_ReceiveBatch := ZERROR;
Exit
END
END
END
ELSE
BEGIN
RZ_ReceiveBatch := c;
Exit
END
END {case}
END {while}
END;
FUNCTION Zmodem_Receive(path: STRING; comport: WORD; baudrate: LONGINT): BOOLEAN;
VAR
i: INTEGER;
BEGIN
zbaud := baudrate;
zport := comport;
Z_OpenWindow(TPZVER);
Z_Message('Initializing...');
IF (NOT Z_AsyncOn(comport,baudrate)) THEN
BEGIN
ClrScr;
WRITELN('Unable to open:');
WRITELN('Port: ',comport);
WRITELN('Baud: ',baudrate);
Delay(2000);
Z_CloseWindow;
Zmodem_Receive := FALSE;
Exit
END;
zrxpath := path;
IF (zrxpath[Length(zrxpath)] <> '\') AND (zrxpath <> '') THEN
zrxpath := zrxpath + '\';
rxtimeout := 100;
tryzhdrtype := ZRINIT;
i := RZ_InitReceiver;
IF (i = ZCOMPL) OR ((i = ZFILE) AND ((RZ_ReceiveBatch) = ZOK)) THEN
BEGIN
Z_Message('Restoring async params');
Z_AsyncOff;
Z_CloseWindow;
Zmodem_Receive := TRUE
END
ELSE
BEGIN
Z_ClearOutbound;
Z_Message('Sending CAN');
Z_SendCan;
Z_Message('Restoring async params');
Z_AsyncOff;
Z_CloseWindow;
Zmodem_Receive := FALSE;
END
END;
(*######### SEND ROUTINES #####################################*)
VAR
infile: FILE;
strtpos: LONGINT;
rxbuflen: INTEGER;
txbuf: buftype;
blkred: INTEGER;
PROCEDURE SZ_Z_SendByte(b: BYTE);
BEGIN
IF ((b AND $7F) IN [16,17,19,24]) OR (((b AND $7F) = 13) AND ((lastsent AND $7F) = 64)) THEN
BEGIN
Z_SendByte(ZDLE);
lastsent := (b XOR 64)
END
ELSE
lastsent := b;
Z_SendByte(lastsent)
END;
PROCEDURE SZ_SendBinaryHead32(htype: BYTE; VAR hdr: hdrtype);
VAR
crc: LONGINT;
n: INTEGER;
BEGIN
Z_SendByte(ZPAD);
Z_SendByte(ZDLE);
Z_SendByte(ZBIN32);
SZ_Z_SendByte(htype);
crc := UpdC32(htype,$FFFFFFFF);
FOR n := 0 TO 3 DO
BEGIN
SZ_Z_SendByte(hdr[n]);
crc := UpdC32(hdr[n],crc)
END;
crc := (NOT crc);
FOR n := 0 TO 3 DO
BEGIN
SZ_Z_SendByte(BYTE(crc));
crc := (crc SHR 8)
END;
IF (htype <> ZDATA) THEN
Delay(500)
END;
PROCEDURE SZ_SendBinaryHeader(htype: BYTE; VAR hdr: hdrtype);
VAR
crc: WORD;
n: INTEGER;
BEGIN
IF (usecrc32) THEN
BEGIN
SZ_SendBinaryHead32(htype,hdr);
Exit
END;
Z_SendByte(ZPAD);
Z_SendByte(ZDLE);
Z_SendByte(ZBIN);
SZ_Z_SendByte(htype);
crc := UpdCrc(htype,0);
FOR n := 0 TO 3 DO
BEGIN
SZ_Z_SendByte(hdr[n]);
crc := UpdCrc(hdr[n],crc)
END;
crc := UpdCrc(0,crc);
crc := UpdCrc(0,crc);
SZ_Z_SendByte(Lo(crc SHR 8));
SZ_Z_SendByte(Lo(crc));
IF (htype <> ZDATA) THEN
Delay(500)
END;
PROCEDURE SZ_SendDa32(VAR buf: buftype; blength: INTEGER; frameend: BYTE);
VAR
crc: LONGINT;
t: INTEGER;
BEGIN
crc := $FFFFFFFF;
FOR t := 0 TO (blength - 1) DO
BEGIN
SZ_Z_SendByte(buf[t]);
crc := UpdC32(buf[t],crc)
END;
crc := UpdC32(frameend,crc);
crc := (NOT crc);
Z_SendByte(ZDLE);
Z_SendByte(frameend);
FOR t := 0 TO 3 DO
BEGIN
SZ_Z_SendByte(BYTE(crc));
crc := (crc SHR 8)
END;
BEGIN
Z_SendByte(17);
Delay(500)
END
END;
PROCEDURE SZ_SendData(VAR buf: buftype; blength: INTEGER; frameend: BYTE);
VAR
crc: WORD;
t: INTEGER;
BEGIN
IF (usecrc32) THEN
BEGIN
SZ_SendDa32(buf,blength,frameend);
Exit
END;
crc := 0;
FOR t := 0 TO (blength - 1) DO
BEGIN
SZ_Z_SendByte(buf[t]);
crc := UpdCrc(buf[t],crc)
END;
crc := UpdCrc(frameend,crc);
Z_SendByte(ZDLE);
Z_SendByte(frameend);
crc := UpdCrc(0,crc);
crc := UpdCrc(0,crc);
SZ_Z_SendByte(Lo(crc SHR 8));
SZ_Z_SendByte(Lo(crc));
IF (frameend = ZCRCW) THEN
BEGIN
Z_SendByte(17);
Delay(500)
END
END;
PROCEDURE SZ_EndSend;
VAR
done: BOOLEAN;
BEGIN
done := FALSE;
REPEAT
Z_PutLongIntoHeader(txpos);
SZ_SendBinaryHeader(ZFIN,txhdr);
CASE Z_GetHeader(rxhdr) OF
ZFIN: BEGIN
Z_SendByte(Ord('O'));
Z_SendByte(Ord('O'));
Delay(500);
Z_ClearOutbound;
Exit
END;
ZCAN,
RCDO,
ZFERR,
ZTIMEOUT: Exit
END {case}
UNTIL (done)
END;
FUNCTION SZ_GetReceiverInfo: INTEGER;
VAR
rxflags, n, c: INTEGER;
BEGIN
Z_Message('Getting info.');
FOR n := 1 TO 10 DO
BEGIN
c := Z_GetHeader(rxhdr);
Z_Frame(c);
CASE c OF
ZCHALLENGE: BEGIN
Z_PutLongIntoHeader(rxpos);
Z_SendHexHeader(ZACK,txhdr)
END;
ZCOMMAND: BEGIN
Z_PutLongIntoHeader(LONGINT(0));
Z_SendHexHeader(ZRQINIT,txhdr)
END;
ZRINIT: BEGIN
rxbuflen := (WORD(rxhdr[ZP1]) SHL 8) OR rxhdr[ZP0];
usecrc32 := ((rxhdr[ZF0] AND CANFC32) <> 0);
Z_ShowCheck(usecrc32);
SZ_GetReceiverInfo := ZOK;
Exit
END;
ZCAN,
RCDO,
ZTIMEOUT: BEGIN
SZ_GetReceiverInfo := ZERROR;
Exit
END
ELSE
IF (c <> ZRQINIT) OR (rxhdr[ZF0] <> ZCOMMAND) THEN
Z_SendHexHeader(ZNAK,txhdr)
END {case}
END; {for}
SZ_GetReceiverInfo := ZERROR
END;
FUNCTION SZ_SyncWithReceiver: INTEGER;
VAR
c, num_errs: INTEGER;
done: BOOLEAN;
BEGIN
num_errs := 7;
done := FALSE;
REPEAT
c := Z_GetHeader(rxhdr);
Z_Frame(c);
Z_ClearInbound;
CASE c OF
ZTIMEOUT: BEGIN
Dec(num_errs);
IF (num_errs < 0) THEN
BEGIN
SZ_SyncWithReceiver := ZERROR;
Exit
END
END;
ZCAN,
ZABORT,
ZFIN,
RCDO: BEGIN
SZ_SyncWithReceiver := ZERROR;
Exit
END;
ZRPOS: BEGIN
IF (NOT Z_SeekFile(infile,rxpos)) THEN
BEGIN
Z_Message('File seek error');
SZ_SyncWithReceiver := ZERROR;
Exit
END;
Z_Message('Repositioning...');
Z_ShowLoc(rxpos);
txpos := rxpos;
SZ_SyncWithReceiver := c;
Exit
END;
ZSKIP,
ZRINIT,
ZACK: BEGIN
SZ_SyncWithReceiver := c;
Exit
END
ELSE
BEGIN
Z_Message('I dunno what happened!');
SZ_SendBinaryHeader(ZNAK,txhdr)
END
END {case}
UNTIL (done)
END;
FUNCTION SZ_SendFileData: INTEGER;
LABEL
waitack, somemore, oops;
VAR
c, e: INTEGER;
newcnt, blklen, blkred, maxblklen, goodblks, goodneeded: WORD;
BEGIN
Z_Message('Sending file...');
goodneeded := 1;
IF (zbaud < 300) THEN
maxblklen := 128
ELSE
maxblklen := (WORD(zbaud) DIV 300) * 256;
IF (maxblklen > ZBUFSIZE) THEN
maxblklen := ZBUFSIZE;
IF (rxbuflen > 0) AND (rxbuflen < maxblklen) THEN
maxblklen := rxbuflen;
blklen := maxblklen;
ztime := Z_SetTimer;
somemore:
IF (Z_CharAvail) THEN
BEGIN
WaitAck:
c := SZ_SyncWithReceiver;
Z_Frame(c);
CASE c OF
ZSKIP: BEGIN
SZ_SendFileData := ZSKIP;
Exit
END;
ZACK: {null};
ZRPOS: BEGIN
Inc(zerrors);
Z_Errors(zerrors);
IF ((blklen SHR 2) > 32) THEN
blklen := (blklen SHR 2)
ELSE
blklen := 32;
goodblks := 0;
goodneeded := (goodneeded SHL 1) OR 1
END;
ZRINIT: BEGIN
SZ_SendFileData := ZOK;
Exit
END
ELSE
BEGIN
SZ_SendFileData := ZERROR;
Exit
END
END {case};
WHILE (Z_CharAvail) DO
BEGIN
CASE (Z_GetByte(1)) OF
CAN,
ZPAD: GOTO waitack;
RCDO: BEGIN
SZ_SendFileData := ZERROR;
Exit
END
END {case}
END
END; {if char avail}
newcnt := rxbuflen;
Z_PutLongIntoHeader(txpos);
SZ_SendBinaryHeader(ZDATA,txhdr);
Z_Message('Sending data header');
REPEAT
IF (KeyPressed) THEN
IF (ReadKey = #27) THEN
BEGIN
Z_Message('Aborted from keyboard');
Z_SendCan;
GOTO oops
END;
IF (NOT Z_Carrier) THEN
GOTO oops;
IF (NOT Z_ReadFile(infile,txbuf,blklen,blkred)) THEN
BEGIN
Z_Message('Error reading disk');
Z_SendCan;
GOTO oops
END;
IF (blkred < blklen) THEN
e := ZCRCE
ELSE IF (rxbuflen <> 0) AND ((newcnt - blkred) <= 0) THEN
BEGIN
newcnt := (newcnt - blkred);
e := ZCRCW
END
ELSE
e := ZCRCG;
SZ_SendData(txbuf,blkred,e);
txpos := txpos + blkred;
Z_ShowLoc(txpos);
Inc(goodblks);
IF (blklen < maxblklen) AND (goodblks > goodneeded) THEN
BEGIN
IF ((blklen SHL 1) < maxblklen) THEN
blklen := (blklen SHL 1)
ELSE
blklen := maxblklen;
goodblks := 0
END;
IF (e = ZCRCW) THEN
GOTO waitack;
WHILE (Z_CharAvail) DO
BEGIN
CASE Z_GetByte(1) OF
CAN,
ZPAD: BEGIN
Z_Message('Trouble?');
Z_ClearOutbound;
SZ_SendData(txbuf,0,ZCRCE);
GOTO waitack
END;
RCDO: BEGIN
SZ_SendFileData := ZERROR;
Exit
END
END {case}
END {while}
UNTIL (e <> ZCRCG);
REPEAT
Z_PutLongIntoHeader(txpos);
Z_Message('Sending EOF');
SZ_SendBinaryHeader(ZEOF,txhdr);
c := SZ_SyncWithReceiver;
CASE c OF
ZACK: {null};
ZRPOS: GOTO somemore;
ZRINIT: BEGIN
SZ_SendFileData := ZOK;
Exit
END;
ZSKIP: BEGIN
SZ_SendFileData := c;
Exit
END
ELSE
oops: BEGIN
SZ_SendFileData := ZERROR;
Exit
END
END {case}
UNTIL (c <> ZACK)
END;
FUNCTION SZ_SendFile: INTEGER;
VAR
c: INTEGER;
done: BOOLEAN;
BEGIN
zerrors := WORD(0);
done := FALSE;
REPEAT
IF (KeyPressed) THEN
IF (ReadKey = #27) THEN
BEGIN
Z_SendCan;
Z_Message('Aborted from keyboard');
SZ_SendFile := ZERROR;
Exit
END;
IF (NOT Z_Carrier) THEN
BEGIN
Z_Message('Lost carrier');
SZ_SendFile := ZERROR;
Exit
END;
FillChar(txhdr,4,0);
txhdr[ZF0] := ZCRESUM; {recover}
SZ_SendBinaryHeader(ZFILE,txhdr);
SZ_SendData(txbuf,ZBUFSIZE,ZCRCW);
REPEAT
c := Z_GetHeader(rxhdr);
Z_Frame(c);
CASE c OF
ZCAN,
RCDO,
ZTIMEOUT,
ZFIN,
ZABORT: BEGIN
SZ_SendFile := ZERROR;
Exit
END;
ZRINIT: {null - this will cause a loopback};
ZCRC: BEGIN
Z_PutLongIntoHeader(Z_FileCRC32(infile));
Z_SendHexHeader(ZCRC,txhdr)
END;
ZSKIP: BEGIN
SZ_SendFile := c;
Exit
END;
ZRPOS: BEGIN
IF (NOT Z_SeekFile(infile,rxpos)) THEN
BEGIN
Z_Message('File positioning error');
Z_SendHexHeader(ZFERR,txhdr);
SZ_SendFile := ZERROR;
Exit
END;
Z_Message('Setting start position');
Z_ShowLoc(rxpos);
strtpos := rxpos;
txpos := rxpos;
SZ_SendFile := SZ_SendFileData;
Exit
END
END {case}
UNTIL (c <> ZRINIT)
UNTIL (done)
END;
FUNCTION Zmodem_Send(pathname: STRING; lastfile: BOOLEAN; comport: WORD; baudrate: LONGINT): BOOLEAN;
VAR
s: STRING;
n: INTEGER;
BEGIN
zerrors := 0;
zbaud := baudrate;
zport := comport;
Z_OpenWindow(TPZVER);
IF (NOT Z_AsyncOn(comport,baudrate)) THEN
BEGIN
Z_Message('Unable to open port');
Delay(2000);
Z_CloseWindow;
Zmodem_Send := FALSE;
Exit
END;
IF (NOT Z_Carrier) THEN
BEGIN
Z_Message('Lost carrier');
Delay(2000);
Z_CloseWindow;
Z_AsyncOff;
Zmodem_Send := FALSE;
Exit
END;
IF (NOT Z_FindFile(pathname,fname,fsize,ftime)) THEN
BEGIN
Z_Message('Unable to find/open file');
SZ_EndSend;
Z_CloseWindow;
Z_AsyncOff;
Zmodem_Send := FALSE;
Exit
END;
Z_ShowName(fname);
Z_ShowSize(fsize);
Z_ShowTransferTime(fsize,zbaud);
Str(fsize,s);
s := (fname + #0 + s + ' ');
s := s + Z_ToUnixDate(ftime);
n := Length(s);
FOR n := 1 TO Length(s) DO
BEGIN
IF (s[n] IN ['A'..'Z']) THEN
s[n] := Chr(Ord(s[n]) + $20)
END;
FillChar(txbuf,ZBUFSIZE,0);
Move(s[1],txbuf[0],Length(s));
IF (zbaud > 0) THEN
rxtimeout := INTEGER(614400 DIV zbaud)
ELSE
rxtimeout := 100;
IF (rxtimeout < 100) THEN
rxtimeout := 100;
attn[0] := Ord('r');
attn[1] := Ord('z');
attn[3] := 13;
attn[4] := 0;
Z_PutString(attn);
FillChar(attn,SizeOf(attn),0);
Z_PutLongIntoHeader(LONGINT(0));
Z_Message('Sending ZRQINIT');
Z_SendHexHeader(ZRQINIT,txhdr);
IF (SZ_GetReceiverInfo = ZERROR) THEN
BEGIN
Z_CloseWindow;
Z_AsyncOff;
Zmodem_Send := FALSE;
Exit
END;
IF (NOT Z_OpenFile(infile,pathname)) THEN
IF (IOresult <> 0) THEN
BEGIN
Z_Message('Failure to open file');
Z_SendCan;
Z_CloseWindow;
Z_AsyncOff;
Zmodem_Send := FALSE;
Exit
END;
n := SZ_SendFile;
zcps := (fsize DIV (Z_SetTimer - ztime));
Z_CloseFile(infile);
Z_Frame(n);
Str(zcps:4,s);
Z_Message(s+' cps');
IF (n = ZOK) AND (lastfile) THEN
SZ_EndSend
ELSE
Z_SendCan;
Z_CloseWindow;
Z_AsyncOff;
Zmodem_Send := TRUE
END;
END.