Unit m_Protocol_Zmodem; {$I M_OPS.PAS} {.$DEFINE ZDEBUG} Interface // Ported from ZMODEM.C Uses DOS, m_CRC, m_DateTime, m_FileIO, m_Strings, m_Input, m_io_Base, m_Protocol_Base, m_Protocol_Queue; Const ZBufSize = 1024; // 1024 only maybe 8k ZEDZAP someday ZAttnLen = 32; RxTimeOut : Word = 500; Type ZHdrType = Array[0..3] of Byte; ZBufType = Array[0..ZBUFSIZE - 1] of Byte; TProtocolZmodem = Class(TProtocolBase) UseCRC32 : Boolean; EscapeAll : Boolean; LastSent : Byte; Attn : String[ZAttnLen]; TxHdr : ZHdrType; TxBuf : ZBufType; RxBuf : ZBufType; RxFrameIdx : SmallInt; RxType : Byte; TxPos : LongInt; RxPos : LongInt; RxHdr : ZHdrType; RxBufLen : SmallInt; WrkFile : File; RxBytes : LongInt; RxCount : LongInt; Constructor Create (Var C: TIOBase; Var Q: TProtocolQueue); Override; Destructor Destroy; Override; Procedure QueueReceive; Override; Procedure QueueSend; Override; Function ZInitReceiver : SmallInt; Function ZGetByte : SmallInt; Function ZDLRead : SmallInt; Function ZGetHex : SmallInt; Function ZSendFile : SmallInt; Function ZInitSender : SmallInt; Function ZReceiveFile : SmallInt; Procedure ZPutHex (B: Byte); Procedure ZPutLong (Pos: LongInt); Procedure ZSendHexHeader (FrameType: Byte); Function ZGetHeader (Var Hdr: ZHdrType) : SmallInt; Function ZReceiveHexHeader (Var Hdr: ZHdrType) : SmallInt; Function ZReceiveBinaryHeader (Var Hdr: ZHdrType) : SmallInt; Function ZReceiveBinaryHeader32 (Var Hdr: ZHdrType) : SmallInt; Function ZGetLong (Var Hdr: ZHdrType) : LongInt; Procedure ZSendBinaryHeader (FrameType: Byte); Procedure SendEscaped (B: SmallInt); Procedure ZSendData (BufSize : SmallInt; FrameEnd : Byte); Function ZReceiveData (Var Buf: ZBufType; Len: SmallInt): SmallInt; Procedure ZAckBiBi; Procedure ZEndSender; Procedure DoAbortSequence; End; Implementation Const CANBRK = 4; EscAll = $0040; ZCRC = 13; ZABORT = 7; ZRQINIT = 0; ZPAD = 42; ZDLE = 24; ZHEX = 66; ZACK = 3; ZFIN = 8; ZERROR = -1; ZTIMEOUT = -2; RCDO = -3; ZBIN32 = 67; XON = 17; XOFF = 19; CAN = 24; ZCAN = 16; DLE = 16; ZBIN = 65; GOTCAN = 272; ZCRCE = 104; ZCRCG = 105; ZCRCQ = 106; ZCRCW = 107; GOTOR = 256; ZRUB0 = 108; ZRUB1 = 109; ZP0 = 0; ZP1 = 1; ZP2 = 2; ZP3 = 3; CANFDX = 1; CANOVIO = 2; CANBREAK = 4; CANFC32 = 32; ZCHALLENGE = 14; ZRINIT = 1; ZF0 = 3; ZOK = 0; ZSKIP = 5; ZCRESUM = 3; ZDATA = 10; ZFILE = 4; ZRPOS = 9; ZEOF = 11; ZCOMMAND = 18; ZNAK = 6; GOTCRCE = 360; GOTCRCG = 361; GOTCRCQ = 362; GOTCRCW = 363; ZSINIT = 2; ZFREECNT = 17; ZCOMPL = 15; DleHi = Dle OR $80; XonHi = Xon OR $80; XoffHi = Xoff OR $80; CancelStr : String = #24#24#24#24#24#24#24#24#8#8#8#8#8#8#8#8; {$IFDEF ZDEBUG} Function HeaderType (B: SmallInt) : String; Begin Case B of ZERROR : Result := 'ZERROR'; RCDO : Result := 'RCDO'; ZTIMEOUT: Result := 'ZTIMEOUT'; ZBIN : Result := 'ZBIN'; ZBIN32 : Result := 'ZBIN32'; ZHEX : Result := 'ZHEX'; CAN : Result := 'CAN'; ZRQINIT : Result := 'ZRQINIT'; ZEOF : Result := 'ZEOF'; ZFILE : Result := 'ZFILE'; ZRPOS : Result := 'ZRPOS'; ZRINIT : Result := 'ZRINIT'; ZSINIT : Result := 'ZSINIT'; ZFREECNT: Result := 'ZFREECNT'; ZCOMMAND: Result := 'ZCOMMAND'; ZCOMPL : Result := 'ZCOMPL'; ZFIN : Result := 'ZFIN'; ZCAN : Result := 'ZCAN'; ZDATA : Result := 'ZDATA'; GOTCRCE : Result := 'GOTCRCE'; GOTCRCG : Result := 'GOTCRCG'; GOTCRCQ : Result := 'GOTCRCQ'; GOTCRCW : Result := 'GOTCRCW'; ZCRC : Result := 'ZCRC'; Else Result := 'UNKNOWN:' + strI2S(Ord(B)); End; End; {$ENDIF} {$IFDEF ZDEBUG} Procedure ZLOG (Str: String); Var T : Text; Begin Assign (T, 'zlog.txt'); {$I-} Append(T); {$I+} If IoResult <> 0 Then ReWrite(T); WriteLn(T, Str); Close(T); End; {$ENDIF} Constructor TProtocolZmodem.Create (Var C: TIOBase; Var Q: TProtocolQueue); Begin Inherited Create (C, Q); Status.Protocol := 'Zmodem'; LastSent := 0; EscapeAll := True; Attn := ''; End; Destructor TProtocolZmodem.Destroy; Begin Inherited Destroy; End; Procedure TProtocolZmodem.ZPutLong (Pos : LongInt); Begin TxHdr[ZP0] := Byte(Pos); TxHdr[ZP1] := Byte(Pos SHR 8); TxHdr[ZP2] := Byte(Pos SHR 16); TxHdr[ZP3] := Byte(Pos SHR 24); End; Procedure TProtocolZmodem.ZPutHex (B: Byte); Const Digits : Array[0..15] of Char = '0123456789abcdef'; Begin Client.BufWriteChar (Digits[B SHR 4]); Client.BufWriteChar (Digits[B AND $0F]); End; Procedure TProtocolZmodem.ZSendHexHeader (FrameType: Byte); Var CRC : SmallInt; Count : Byte; Begin Client.BufWriteChar (Char(ZPAD)); Client.BufWriteChar (Char(ZPAD)); Client.BufWriteChar (Char(ZDLE)); Client.BufWriteChar (Char(ZHEX)); ZPutHex (FrameType); CRC := Crc16(FrameType, 0); For Count := 0 to 3 Do Begin ZPutHex (TxHdr[Count]); CRC := Crc16(TxHdr[Count], CRC); End; CRC := Crc16(0, CRC); CRC := Crc16(0, CRC); ZPutHex (Lo(SmallInt(CRC SHR 8))); ZPutHex (Lo(CRC)); Client.BufWriteChar (#13); Client.BufWriteChar (#10); If (FrameType <> ZFIN) And (FrameType <> ZACK) Then Client.BufWriteChar (Char(XON)); Client.BufFlush; End; Function TProtocolZmodem.ZGetByte : SmallInt; Begin While Connected Do Begin Result := ReadByteTimeOut(RxTimeOut); If Result < 0 Then Begin Result := ZTIMEOUT; Exit; End; Result := Result AND $007F; Case Result of XON, XOFF : Continue; Else Exit; End; End; Result := RCDO; End; Function TProtocolZmodem.ZDLRead : SmallInt; Begin Result := ReadByteTimeOut(RxTimeOut); If Result <> ZDLE Then Exit; Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Begin Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Begin Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Result := ReadByteTimeOut(RxTimeOut); End End; Case Result of CAN : Result := GOTCAN; ZCRCE, ZCRCG, ZCRCQ, ZCRCW : Result := (Result OR 256); ZRUB0 : Result := $007F; ZRUB1 : Result := $00FF; Else If ((Result AND $60) = $40) Then Result := Result XOR $40 Else Begin Result := ZERROR; {$IFDEF ZDEBUG} ZLog('ZDLRead -> Got ZERROR'); {$ENDIF} End; End; End; (* Function TProtocolZmodem.ZDLRead : SmallInt; Begin Result := ReadByteTimeOut(RxTimeOut); If Result <> ZDLE Then Exit; Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Begin Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Begin Result := ReadByteTimeOut(RxTimeOut); If Result = CAN Then Result := ReadByteTimeOut(RxTimeOut); End End; Case Result of CAN : Result := GOTCAN; ZCRCE, ZCRCG, ZCRCQ, ZCRCW : Result := (Result OR 256); ZRUB0 : Result := $007F; ZRUB1 : Result := $00FF; Else If Result > 0 Then If ((Result AND $60) = $40) Then Result := Result XOR $40 Else Result := ZERROR; End; End; *) Function TProtocolZmodem.ZReceiveBinaryHeader (Var Hdr: ZHdrType) : SmallInt; Var C : SmallInt; N : SmallInt; CRC : Word; Begin C := ZDLRead; If C < 0 Then Begin ZReceiveBinaryHeader := C; Exit; End; RxType := C; CRC := Crc16(RxType, 0); For N := 0 To 3 Do Begin C := ZDLRead; If Hi(C) <> 0 Then Begin ZReceiveBinaryHeader := C; Exit; End; Hdr[N] := Lo(C); CRC := Crc16(Lo(C), CRC); End; C := ZDLRead; If Hi(C) <> 0 Then Begin ZReceiveBinaryHeader := C; Exit; End; CRC := Crc16(Lo(C), CRC); C := ZDLRead; If Hi(C) <> 0 Then Begin ZReceiveBinaryHeader := C; Exit; End; CRC := Crc16(Lo(C), CRC); If CRC <> 0 Then Begin {$IFDEF ZDEBUG} ZLog('ZReceiveBinaryHeader -> CRC error'); {$ENDIF} ZReceiveBinaryHeader := ZERROR; Exit; End; ZReceiveBinaryHeader := RxType; End; Function TProtocolZmodem.ZReceiveBinaryHeader32 (Var Hdr: ZHdrType) : SmallInt; Var C : SmallInt; Loop : Byte; CRC : LongInt; Begin C := ZDLRead; If C < 0 Then Begin ZReceiveBinaryHeader32 := C; Exit; End; RxType := C; CRC := Crc32(RxType, LongInt($FFFFFFFF)); For Loop := 0 To 3 Do Begin C := ZDLRead; If Hi(C) <> 0 Then Begin ZReceiveBinaryHeader32 := C; Exit; End; Hdr[Loop] := Lo(C); CRC := Crc32(Lo(C), CRC); End; For Loop := 0 To 3 Do Begin C := ZDLRead; If Hi(C) <> 0 Then Begin ZReceiveBinaryHeader32 := C; Exit; End; CRC := Crc32(Lo(C), CRC); End; If CRC <> LongInt($DEBB20E3) Then Begin {$IFDEF ZDEBUG} ZLog('ZReceieveBinaryHeader32 -> CRC error'); {$ENDIF} ZReceiveBinaryHeader32 := ZERROR; Exit; End; ZReceiveBinaryHeader32 := RxType; End; Procedure TProtocolZmodem.SendEscaped (B: SmallInt); Begin Case B of DLE, DLEHI, XON, XONHI, XOFF, XOFFHI, ZDLE : Begin Client.BufWriteChar(Char(ZDLE)); LastSent := B XOR $40; End; 13, 13 OR $80 : If {EscapeAll And} (LastSent AND $7F = Ord('@')) Then Begin Client.BufWriteChar(Char(ZDLE)); LastSent := B XOR $40; End Else LastSent := B; 255 : Begin Client.BufWriteChar(Char(ZDLE)); LastSent := ZRUB1; End; Else If {(EscapeAll) and} ((B AND $60) = 0) Then Begin Client.BufWriteChar(Char(ZDLE)); LastSent := B XOR $40; End Else LastSent := B; End; Client.BufWriteChar(Char(LastSent)); End; Procedure TProtocolZmodem.ZSendBinaryHeader (FrameType : Byte); Var ulCRC : LongInt; CRC : SmallInt; Count : SmallInt; Begin Client.BufWriteChar(Char(ZPAD)); Client.BufWriteChar(Char(ZDLE)); If UseCRC32 Then Begin Client.BufWriteChar(Char(ZBIN32)); SendEscaped (FrameType); ulCRC := Crc32(FrameType, LongInt($FFFFFFFF)); For Count := 0 to 3 Do Begin SendEscaped (TxHdr[Count]); ulCRC := Crc32 (TxHdr[Count], ulCRC); End; ulCRC := Not ulCRC; For Count := 0 to 3 Do Begin SendEscaped (Byte(ulCRC)); ulCRC := ulCRC SHR 8; End; End Else Begin Client.BufWriteChar(Char(ZBIN)); SendEscaped (FrameType); CRC := Crc16(FrameType, 0); For Count := 0 to 3 Do Begin SendEscaped (TxHdr[Count]); CRC := Crc16 (TxHdr[Count], CRC); End; CRC := Crc16(0, CRC); CRC := Crc16(0, CRC); SendEscaped (Lo(SmallInt(CRC SHR 8))); SendEscaped (Lo(CRC)); End; Client.BufFlush; If FrameType <> ZDATA Then WaitMS(250); { do we need this? } End; Function TProtocolZmodem.ZGetHex : SmallInt; Var C : SmallInt; N : SmallInt; Begin C := ZGetByte; If C < 0 Then Begin ZGetHex := C; Exit; End; N := C - 48; If N > 9 Then N := N - 39; If (N AND $FFF0) <> 0 Then Begin ZGetHex := ZERROR; Exit; End; C := ZGetByte; If C < 0 Then Begin ZGetHex := C; Exit; End; C := C - 48; If C > 9 Then C := C - 39; If (C AND $FFF0) <> 0 Then Begin ZGetHex := ZERROR; Exit; End; C := C + (N SHL 4); ZGetHex := C; End; Function TProtocolZmodem.ZGetLong (Var Hdr: ZHdrType) : LongInt; Begin Result := Hdr[ZP3]; Result := (Result SHL 8) OR Hdr[ZP2]; Result := (Result SHL 8) OR Hdr[ZP1]; Result := (Result SHL 8) OR Hdr[ZP0]; End; Function TProtocolZmodem.ZReceiveHexHeader (Var Hdr : ZHdrType) : SmallInt; Var N : SmallInt; C : SmallInt; CRC : Word; Begin C := ZGetHex; If C < 0 Then Begin ZReceiveHexHeader := C; Exit; End; RxType := C; CRC := Crc16(RxType, 0); For N := 0 To 3 Do Begin C := ZGetHex; If C < 0 Then Begin ZReceiveHexHeader := C; Exit; End; Hdr[N] := Lo(C); CRC := Crc16(Lo(C), CRC); End; C := ZGetHex; If C < 0 Then Begin ZReceiveHexHeader := C; Exit; End; CRC := Crc16(Lo(C), CRC); C := ZGetHex; If C < 0 Then Begin ZReceiveHexHeader := C; Exit; End; CRC := Crc16(Lo(C), CRC); If (CRC <> 0) Then Begin {$IFDEF ZDEBUG} ZLog('ZReceieveHexHeader -> CRC error'); {$ENDIF} ZReceiveHexHeader := ZERROR; Exit; End; If ReadByteTimeOut(20) = 13 Then C := ReadByteTimeOut(20); ZReceiveHexHeader := RxType; End; Function TProtocolZmodem.ZGetHeader (Var Hdr: ZHdrType) : SmallInt; Label Again, Again2, Splat, Finished; Var C : SmallInt; SyncTries : SmallInt; CanCount : SmallInt; Begin SyncTries := 32; CanCount := 5; RxFrameIdx := 0; RxType := 0; Again: C := ZGetByte; Case C of ZPAD : Goto Splat; RCDO, ZTIMEOUT: Goto Finished; CAN : Begin Dec (CanCount); If CanCount <= 0 Then Begin C := ZCAN; Goto Finished; End; End; Else Again2: Dec (SyncTries); If SyncTries = 0 Then Begin ZGetHeader := ZERROR; Exit; End; If C <> CAN Then CanCount := 5; Goto Again; End; CanCount := 5; Splat: C := ZGetByte; Case C of ZPAD : Goto Splat; RCDO, ZTIMEOUT: Goto Finished; ZDLE : ; Else Goto Again2; End; C := ZGetByte; Case C of RCDO, ZTIMEOUT: Goto Finished; ZBIN : Begin RxFrameIdx := ZBIN; C := ZReceiveBinaryHeader(Hdr); End; ZBIN32 : Begin RxFrameIdx := ZBIN32; C := ZReceiveBinaryHeader32(Hdr); End; ZHEX : Begin RxFrameIdx := ZHEX; C := ZReceiveHexHeader(Hdr); End; CAN : Begin Dec (CanCount); If CanCount <= 0 Then Begin C := ZCAN; Goto Finished; End; Goto Again2; End; Else Goto Again2; End; RxPos := ZGetLong(Hdr); Finished: If C = GOTCAN Then C := ZCAN; {$IFDEF ZDEBUG} ZLog('ZGetHeader -> Result ' + HeaderType(C)); {$ENDIF} Result := C; End; Function TProtocolZmodem.ZInitReceiver : SmallInt; Var I : SmallInt; Begin ZPutLong (0); ZSendHexHeader (ZRQINIT); {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> begin ZRQINIT want ZRINIT'); {$ENDIF} For I := 0 to 10 Do Begin If AbortTransfer Then Break; Case ZGetHeader(RxHdr) of ZCHALLENGE: Begin {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> Got ZCHALLENGE'); {$ENDIF} ZPutLong (RxPos); ZSendHexHeader (ZACK); End; ZCOMMAND : Begin {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> Got ZCOMMAND'); {$ENDIF} ZPutLong (0); ZSendHexHeader (ZRQINIT); End; ZRINIT : Begin RxBufLen := (Word(RxHdr[ZP1]) SHL 8) OR RxHdr[ZP0]; UseCrc32 := (RxHdr[ZF0] AND CANFC32) <> 0; EscapeAll := (RxHdr[ZF0] AND ESCALL) = ESCALL; ZInitReceiver := ZOK; {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> ZRINIT'); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> CRC32:' + strI2S(Ord(UseCrc32))); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> EscapeAll:' + strI2S(Ord(EscapeAll))); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> BlockSize:' + strI2S(RxBufLen)); {$ENDIF} Exit; End; RCDO, ZCAN, ZTIMEOUT : Begin {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> Got TIMEOUT/CAN'); {$ENDIF} ZInitReceiver := ZERROR; Exit; End; ZRQINIT : {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> Got ZRQINIT response') {$ENDIF}; Else {$IFDEF ZDEBUG} ZLog('ZInitReceiver -> Unknown sending ZNAK'); {$ENDIF} ZSendHexHeader (ZNAK); End; End; Result := ZERROR; End; Procedure TProtocolZmodem.ZSendData (BufSize: SmallInt; FrameEnd: Byte); Var ulCRC : LongInt; CRC : SmallInt; Count : LongInt; Begin If UseCRC32 Then Begin ulCRC := LongInt($FFFFFFFF); For Count := 0 to BufSize - 1 Do Begin SendEscaped (TxBuf[Count]); ulCRC := Crc32(TxBuf[Count], ulCRC); End; ulCRC := Crc32(FrameEnd, ulCRC); ulCRC := Not ulCRC; Client.BufWriteChar(Char(ZDLE)); Client.BufWriteChar(Char(FrameEnd)); For Count := 0 to 3 Do Begin SendEscaped (Byte(ulCRC)); ulCRC := ulCRC SHR 8; End; End Else Begin CRC := 0; For Count := 0 to BufSize - 1 Do Begin SendEscaped (TxBuf[Count]); CRC := Crc16(TxBuf[Count], CRC); End; CRC := Crc16(FrameEnd, CRC); Client.BufWriteChar(Char(ZDLE)); Client.BufWriteChar(Char(FrameEnd)); CRC := Crc16(0, CRC); CRC := Crc16(0, CRC); SendEscaped (Lo(SmallInt(CRC SHR 8))); SendEscaped (Lo(CRC)); End; If FrameEnd = ZCRCW Then Begin Client.BufWriteChar(Char(XON)); // WaitMS(250); End; Client.BufFlush; End; Function TProtocolZmodem.ZSendFile : SmallInt; Label Start; Var FTime : LongInt; TmpStr : String; C : SmallInt; Res : LongInt; FileDone : Boolean; GoodBlks : Word; GoodNeeded : Word; Begin {$IFDEF ZDEBUG} ZLog(''); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZSendFile -> begin'); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZSendFile -> file:' + Queue.QData[Queue.QPos].FileName); {$ENDIF} Result := ZERROR; Assign (WrkFile, Queue.QData[Queue.QPos]^.FilePath + Queue.QData[Queue.QPos]^.FileName); If Not ioReset (WrkFile, 1, fmReadWrite + fmDenyNone) Then Exit; GetFTime (WrkFile, FTime); Status.FileName := Queue.QData[Queue.QPos]^.FileName; Status.FilePath := Queue.QData[Queue.QPos]^.FilePath; Status.FileSize := Queue.QData[Queue.QPos]^.FileSize; Status.Position := 0; Status.StartPos := 0; Status.StartTime := TimerSeconds; StatusUpdate(False, False); Repeat If AbortTransfer Then Begin Close (WrkFile); Exit; End; FillChar (TxHdr, SizeOf(TxHdr), 0); FillChar (TxBuf, SizeOf(TxBuf), 0); TxHdr[ZF0] := ZCRESUM; TmpStr := Status.FileName + #0 + strI2S(Status.FileSize); Move (TmpStr[1], TxBuf[0], Length(TmpStr)); ZSendBinaryHeader (ZFILE); ZSendData (Length(TmpStr), ZCRCW); {$IFDEF ZDEBUG} ZLog('ZSendFile -> Sending ZFILE want ZRPOS'); {$ENDIF} WaitMS(500); // Delay for older terminal programs apparently Repeat C := ZGetHeader(RxHdr); {$IFDEF ZDEBUG} ZLog('ZSendFile -> Handshake header ' + HeaderType(C)); {$ENDIF} Case C of ZRINIT : ; RCDO, ZCAN, ZABORT, ZFIN, ZTIMEOUT : Begin Close (WrkFile); Exit; End; ZSKIP : Begin Close (WrkFile); ZSendFile := ZSKIP; Exit; End; ZCRC : Begin {$IFDEF ZDEBUG} ZLog('ZSendFile -> Sending File CRC response'); {$ENDIF} ZPutLong(FileCRC32(Status.FilePath + Status.FileName)); ZSendHexHeader(ZCRC); RxPos := 0; // SYNCTERM expects ZDATA after a ZCRC i am not sure // this is correct because how do we know the ZPOS from // receiver if it works this way? zmodem doc isnt very // clear on this. Lets try it... Goto Start; //Continue; End; (* is SYNCTERM really asking for the FREENCNT here????? WTF ZFREECNT: Begin ZPutLong (LongInt($FFFFFFFF)); ZSendHexHeader (ZACK); Continue; End; *) ZRPOS : Goto Start; End; Until (C <> ZRINIT); Until False; Start: {$IFDEF ZDEBUG} ZLog('ZSendFile -> Start transfer at ' + strI2S(RxPos)); {$ENDIF} Seek (WrkFile, RxPos); TxPos := RxPos; FileDone := False; GoodBlks := 0; GoodNeeded := 0; RxBufLen := ZBufSize; Status.Position := RxPos; Status.BlockSize := RxBufLen; StatusUpdate(False, False); If TxPos < Status.FileSize Then Begin ZPutLong (TxPos); ZSendBinaryHeader (ZDATA); End; StatusTimer := TimerSet(StatusCheck); While Not EndTransfer Do Begin If Not FileDone Then Begin ioBlockRead (WrkFile, TxBuf, RxBufLen, Res); If Res > 0 Then Begin If Res < RxBufLen Then ZSendData (Res, ZCRCE) Else ZSendData (Res, ZCRCG); Inc (TxPos, Res); Status.Position := TxPos; Status.BlockSize := Res; If TimerUp(StatusTimer) Then Begin If AbortTransfer Then Break; StatusUpdate(False, False); StatusTimer := TimerSet(StatusCheck); End; {$IFDEF ZDEBUG} ZLog('ZSendFile -> Sent ZDATA block position now: ' + strI2S(TxPos)); {$ENDIF} End Else Begin {$IFDEF ZDEBUG} ZLog('ZSendFile -> Sending ZEOF want ZRINIT'); {$ENDIF} FileDone := True; ZPutLong (TxPos); ZSendBinaryHeader (ZEOF); StatusUpdate(False, False); End; End; Inc (GoodBlks); If (RxBufLen < ZBUFSIZE) And (GoodBlks > GoodNeeded) Then Begin If ((RxBufLen SHL 1) < ZBUFSIZE) Then RxBufLen := RxBufLen SHL 1 Else RxBufLen := ZBUFSIZE; GoodBlks := 0; End; While Client.DataWaiting And Not AbortTransfer Do Begin {$IFDEF ZDEBUG} ZLog('ZSendFile -> Might have packet response, checking'); {$ENDIF} C := ReadByteTimeOut(200); If (C = CAN) or (C = ZPAD) Then Begin C := ZGetHeader(RxHdr); {$IFDEF ZDEBUG} ZLog('ZSendFile -> Got packet response ' + HeaderType(C)); {$ENDIF} Case C of ZACK : Continue; ZRINIT : Begin Close (WrkFile); Result := ZOK; Exit; End; ZRPOS : Begin TxPos := RxPos; FileDone := False; ioSeek (WrkFile, TxPos); {$IFDEF ZDEBUG} ZLog('ZSendFile -> Got ZRPOS Sending ZDATA position: ' + strI2S(TxPos)); {$ENDIF} // Client.PurgeInputData; // Client.PurgeOutputData; If TxPos < Status.FileSize Then Begin ZPutLong (TxPos); ZSendBinaryHeader (ZDATA); End; If RxPos > 0 Then Begin If (RxBufLen SHR 2) > 64 Then RxBufLen := RxBufLen SHR 2 Else RxBufLen := 64; GoodBlks := 0; If GoodNeeded SHL 1 > 16 Then GoodNeeded := 16 Else GoodNeeded := GoodNeeded SHL 1; End; Status.Position := RxPos; Status.BlockSize := RxBufLen; StatusUpdate(False, False); Break; End; ZSKIP : Begin Close (WrkFile); ZSendFile := ZSKIP; Exit; End; End; End {$IFDEF ZDEBUG}Else ZLog('ZSendFile -> Nonsense response: ' + HeaderType(C)) {$ENDIF}; End; End; Close (WrkFile); End; Procedure TProtocolZmodem.ZEndSender; Var TimeOut : LongInt; C : SmallInt; Begin {$IFDEF ZDEBUG} ZLog('ZEndSender -> begin'); {$ENDIF} TimeOut := TimerSet(500); While Not AbortTransfer And Not TimerUp(TimeOut) Do Begin // Client.PurgeInputData; ZPutLong (0); ZSendBinaryHeader (ZFIN); If Not Client.DataWaiting Then WaitMS(500) Else C := ZGetHeader(RxHdr); {$IFDEF ZDEBUG} ZLog('ZEndSender -> Got header:' + HeaderType(C)); {$ENDIF} Case C of ZFIN: Begin Client.BufWriteStr('OO'); Client.BufFlush; Break; End; ZCAN, ZTIMEOUT, RCDO: Break; End; End; End; Procedure TProtocolZmodem.ZAckBiBi; Var Count : Byte; Ch : SmallInt; Begin {$IFDEF ZDEBUG} ZLog('ZAckBiBi -> begin'); {$ENDIF} ZPutLong (0); // Send ZFIN and wait up to 5 seconds for OO For Count := 1 to 5 Do Begin If AbortTransfer Then Break; ZSendHexHeader (ZFIN); Ch := ReadByteTimeOut(100); {$IFDEF ZDEBUG} ZLog('ZAckBiBi -> ZFIN response is ' + HeaderType(Ch)); {$ENDIF} Case Ch of Ord('O') : Begin {$IFDEF ZDEBUG} ZLog('ZAckBiBi -> Got ending O'); {$ENDIF} ReadByteTimeOut(1); Break; End; ZTIMEOUT, RCDO : Break; End; End; End; Function TProtocolZmodem.ZInitSender : SmallInt; Label Again; Var Tmp : SmallInt; N : SmallInt; Errors : SmallInt; Begin UseCRC32 := True; Errors := 0; {$IFDEF ZDEBUG} ZLog('ZInitSender -> begin'); {$ENDIF} For N := 1 to 10 Do Begin If AbortTransfer Then Break; FillChar (TxHdr, SizeOf(TxHdr), 0); // zero out all flags TxHdr[ZF0] := CANFDX OR CANOVIO OR CANFC32 OR CANBRK; If EscapeAll Then TxHdr[ZF0] := TxHdr[ZF0] or ESCALL; {$IFDEF ZDEBUG} ZLog('ZInitSender -> Sending ZRINIT'); {$ENDIF} ZSendHexHeader (ZRINIT); Again: Tmp := ZGetHeader(RxHdr); {$IFDEF ZDEBUG} ZLog('ZInitSender -> Got response ' + HeaderType(Tmp)); {$ENDIF} Case Tmp of ZRQINIT : Continue; ZEOF : Continue; ZTIMEOUT: Continue; ZFILE : Begin If ZReceiveData(RxBuf, ZBUFSIZE) = GOTCRCW Then Begin ZInitSender := ZFILE; Exit; End; ZSendHexHeader (ZNAK); Goto Again; End; ZSINIT : Begin If ZReceiveData (RxBuf, ZATTNLEN) = GOTCRCW Then Begin Attn := ''; Tmp := 0; While RxBuf[Tmp] <> 0 Do Begin Attn := Attn + Chr(RxBuf[Tmp]); Inc (Tmp); End; ZPutLong (1); ZSendHexHeader (ZACK); End Else ZSendHexHeader (ZNAK); (* RxBufLen := (Word(RxHdr[ZP1]) SHL 8) OR RxHdr[ZP0]; UseCrc32 := (RxHdr[ZF0] AND CANFC32) <> 0; EscapeAll := (RxHdr[ZF0] AND ESCALL) = ESCALL; {$IFDEF ZDEBUG} ZLog('ZInitSender -> ZSINIT'); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitSender -> CRC32:' + strI2S(Ord(UseCrc32))); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitSender -> EscapeAll:' + strI2S(Ord(EscapeAll))); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZInitSender -> BlockSize:' + strI2S(RxBufLen)); {$ENDIF} *) Goto Again; End; ZFREECNT: Begin ZPutLong (LongInt($FFFFFFFF)); ZSendHexHeader (ZACK); Goto Again; End; ZCOMMAND: Begin If ZReceiveData (RxBuf, ZBUFSIZE) = GOTCRCW Then Begin ZPutLong (0); Repeat ZSendHexHeader (ZCOMPL); Inc (Errors); Until (Errors >= 10) or (ZGetHeader(RxHdr) = ZFIN); ZAckBiBi; ZInitSender := ZCOMPL; Exit; End Else ZSendHexHeader (ZNAK); Goto Again; End; ZCOMPL : Continue; ZFIN : Begin ZAckBiBi; ZInitSender := ZCOMPL; Exit; End; RCDO, ZCAN : Begin ZInitSender := ZERROR; Exit; End; End; End; ZInitSender := ZOK; End; Function TProtocolZmodem.ZReceiveData (Var Buf: ZBufType; Len: SmallInt) : SmallInt; Label ErrorCRC16, ErrorCRC32; Var C, D : SmallInt; CRC : SmallInt; ulCRC : LongInt; Count : SmallInt; Begin RxCount := 0; {$IFDEF ZDEBUG} ZLog('ZReceiveData -> begin'); {$ENDIF} If RxFrameIdx = ZBIN32 Then Begin ulCRC := LongInt($FFFFFFFF); While (Len >= 0) Do Begin C := ZDLRead; If Hi(C) <> 0 Then Begin ErrorCRC32: Case C of GOTCRCE, GOTCRCG, GOTCRCQ, GOTCRCW : Begin D := C; ulCRC := Crc32(Lo(C), ulCRC); For Count := 1 to 4 Do Begin C := ZDLRead; If Hi(C) <> 0 Then Goto ErrorCRC32; ulCRC := Crc32(Lo(C), ulCRC); End; If (ulCRC <> LongInt($DEBB20E3)) Then Begin {$IFDEF ZDEBUG} ZLog('ZReceiveData -> CRC32 error'); {$ENDIF} Result := ZERROR; Exit; End; {$IFDEF ZDEBUG} ZLog('ZReceiveData -> Successful packet ' + HeaderType(D) + ' size ' + strI2S(RxCount)); {$ENDIF} Result := D; Exit; End; GOTCAN : Begin ZReceiveData := ZCAN; Exit; End; Else {$IFDEF ZDEBUG} ZLog('ZReceiveData -> Got bad frame type? ' + HeaderType(C)); {$ENDIF} ZReceiveData := C; Exit; End; End; Buf[RxCount] := Lo(C); Dec (Len); Inc (RxCount); ulCRC := Crc32(Lo(C), ulCRC); End; End Else Begin CRC := 0; While Len >= 0 Do Begin C := ZDLRead; If Hi(C) <> 0 Then Begin ErrorCRC16: Case C of GOTCRCE, GOTCRCG, GOTCRCQ, GOTCRCW : Begin D := C; For Count := 1 to 2 Do Begin CRC := Crc16(Lo(C), CRC); C := ZDLRead; If Hi(C) <> 0 Then Goto ErrorCRC16; End; CRC := Crc16(Lo(C), CRC); If CRC <> 0 Then Begin {$IFDEF ZDEBUG} ZLog('ZReceiveData -> CRC16 error'); {$ENDIF} ZReceiveData := ZERROR End Else ZReceiveData := D; Exit; End; GOTCAN : Begin ZReceiveData := ZCAN; Exit; End; Else ZReceiveData := C; Exit; End; Buf[RxCount] := Lo(C); Inc(RxCount); Dec(Len); CRC := Crc16(Lo(C), CRC); End; End; End; {$IFDEF ZDEBUG} ZLog('ZReceiveData -> Long packet (frameidx=' + HeaderType(RxFrameIdx) + '; rxcount=' + strI2S(RxCount) + ')'); {$ENDIF} ZReceiveData := ZERROR; End; Function TProtocolZmodem.ZReceiveFile : SmallInt; Label NextHeader, MoreData; Var Tmp : SmallInt; FName : String; FSize : LongInt; RetryCount : SmallInt; C : SmallInt; Begin {$IFDEF ZDEBUG} ZLog(''); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZRecvFile -> begin'); {$ENDIF} FName := ''; FSize := 0; RxBytes := 0; Tmp := 0; While RxBuf[Tmp] <> 0 Do Begin FName := FName + Chr(RxBuf[Tmp]); Inc (Tmp); End; // Strip path if exists, and leading/trailing spaces FName := JustFile(strStripB(FName, ' ')); Inc (Tmp); While (RxBuf[Tmp] <> $20) and (RxBuf[Tmp] <> 0) Do Begin FSize := (FSize * 10) + RxBuf[Tmp] - $30; Inc (Tmp); End; {$IFDEF ZDEBUG} ZLog('ZRecvFile -> File:' + FName); {$ENDIF} {$IFDEF ZDEBUG} ZLog('ZRecvFile -> Size:' + strI2S(FSize)); {$ENDIF} // Client.PurgeInputData; Queue.Add(ReceivePath, FName); Queue.QData[Queue.QSize]^.FileSize := FSize; Queue.QData[Queue.QSize]^.Status := QueueIntransit; Assign (WrkFile, ReceivePath + FName); {$I-} Reset (WrkFile, 1); {$I+} If IoResult = 0 Then Begin If FSize = FileSize(WrkFile) Then Begin // Same size file, SKIP it Close (WrkFile); Queue.QData[Queue.QSize]^.Status := QueueSkipped; ZSendHexHeader (ZSKIP); ZReceiveFile := ZEOF; Exit; End Else If FileSize(WrkFile) < FSize Then Begin // Resume transfer RxBytes := FileSize(WrkFile); Seek (WrkFile, RxBytes); End Else Begin // If adding rename/overwrite support do it either // but for now we just ZSKIP Close (WrkFile); Queue.QData[Queue.QSize]^.Status := QueueSkipped; ZSendHexHeader (ZSKIP); ZReceiveFile := ZEOF; Exit; End; End Else Begin {$I-} ReWrite (WrkFile, 1); {$I+} If IoResult <> 0 Then Begin ZSendHexHeader (ZSKIP); ZReceiveFile := ZEOF; Exit; End; End; {$IFDEF ZDEBUG} ZLog('ZRecvFile -> Begin data'); {$ENDIF} Status.FilePath := ReceivePath; Status.FileName := FName; Status.FileSize := FSize; Status.BlockSize := 0; Status.Position := RxBytes; Status.StartTime := TimerSeconds; StatusUpdate(False, False); RetryCount := 25; Queue.QData[Queue.QSize]^.Status := QueueFailed; StatusTimer := TimerSet(StatusCheck); While Not EndTransfer Do Begin {$IFDEF ZDEBUG} ZLog('ZRecvFile -> Sending ZRPOS ' + strI2S(RxBytes)); {$ENDIF} ZPutLong (RxBytes); ZSendBinaryHeader (ZRPOS); NextHeader: C := ZGetHeader(RxHdr); {$IFDEF ZDEBUG} ZLog('ZRecvFile -> NextHeader -> Got ' + HeaderType(C)); {$ENDIF} Case C of ZNAK, ZTIMEOUT: Begin Dec (RetryCount); If RetryCount < 0 Then Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; End; ZFILE : Begin ZReceiveData (RxBuf, ZBUFSIZE); Continue; End; ZEOF : Begin If ZGetLong(RxHdr) <> RxBytes Then Continue; Status.Position := RxBytes; Status.BlockSize := RxCount; StatusUpdate(False, False); Close (WrkFile); Queue.QData[Queue.QSize]^.Status := QueueSuccess; ZReceiveFile := C; Exit; End; RCDO : Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; ZERROR : Begin Dec (RetryCount); If RetryCount < 0 Then Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; Client.BufWriteStr(Attn); Client.BufFlush; Continue; End; ZDATA : Begin If ZGetLong(RxHdr) <> RxBytes Then Begin {$IFDEF ZDEBUG} ZLog('ZRecvFile -> NextHeader -> ZDATA -> Size not ' + strI2S(RxBytes)); {$ENDIF} Dec(RetryCount); If RetryCount < 0 Then Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; Client.BufWriteStr(Attn); Client.BufFlush; Continue; End; MoreData: If TimerUp(StatusTimer) Then Begin If AbortTransfer Then Break; StatusUpdate(False, False); StatusTimer := TimerSet(StatusCheck); End; C := ZReceiveData(RxBuf, ZBUFSIZE); {$IFDEF ZDEBUG} ZLog('ZRecvFile -> MoreData -> Got ' + HeaderType(C) + ' want data packet'); {$ENDIF} Case C of { we can combine zreceivedata and case here } ZCAN : Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; ZERROR : Begin Dec(RetryCount); If RetryCount < 0 Then Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; Client.BufWriteStr(Attn); Client.BufFlush; End; ZTIMEOUT: Begin Dec(RetryCount); If RetryCount < 0 Then Begin Close (WrkFile); ZReceiveFile := ZERROR; Exit; End; Continue; End; GOTCRCW : Begin RetryCount := 25; BlockWrite (WrkFile, RxBuf, RxCount); RxBytes := RxBytes + RxCount; ZPutLong (RxBytes); ZSendBinaryHeader (ZACK); Status.Position := RxBytes; Status.BlockSize := RxCount; Goto NextHeader; End; GOTCRCQ : Begin RetryCount := 25; BlockWrite (WrkFile, RxBuf, RxCount); RxBytes := RxBytes + RxCount; ZPutLong (RxBytes); ZSendBinaryHeader (ZACK); Status.Position := RxBytes; Status.BlockSize := RxCount; Goto MoreData; End; GOTCRCG : Begin RetryCount := 25; BlockWrite (WrkFile, RxBuf, RxCount); Rxbytes := RxBytes + RxCount; Status.Position := RxBytes; Status.BlockSize := RxCount; Goto MoreData; End; GOTCRCE : Begin RetryCount := 25; BlockWrite (WrkFile, RxBuf, RxCount); RxBytes := RxBytes + RxCount; Status.Position := RxBytes; Status.BlockSize := RxCount; Goto NextHeader; End; End; End; End; End; Close (WrkFile); ZReceiveFile := ZERROR; End; Procedure TProtocolZmodem.DoAbortSequence; Begin If Not Connected Then Exit; Client.PurgeInputData; Client.PurgeOutputData; Client.BufWriteStr(Attn); Client.BufWriteStr(CancelStr); Client.BufFlush; End; Procedure TProtocolZmodem.QueueReceive; Begin Status.Sender := False; StatusUpdate(True, False); RxBufLen := ZBufSize; While Not AbortTransfer Do Begin If ZInitSender = ZFILE Then Begin If ZReceiveFile <> ZEOF Then Break; End Else Break; End; If AbortTransfer Then DoAbortSequence; StatusUpdate(False, True); End; Procedure TProtocolZmodem.QueueSend; Begin Status.Sender := True; StatusUpdate (True, False); Queue.QPos := 0; While Queue.Next And Not AbortTransfer Do Begin If Queue.QPos = 1 Then If ZInitReceiver <> ZOK Then Break; Case ZSendFile of ZOK : Queue.QData[Queue.QPos]^.Status := QueueSuccess; ZSKIP : Queue.QData[Queue.QPos]^.Status := QueueSkipped; ZERROR : Queue.QData[Queue.QPos]^.Status := QueueFailed; End; End; If AbortTransfer Then DoAbortSequence Else ZEndSender; StatusUpdate(False, True); End; End.