www.pudn.com > ymodem.zip > YMODEM.PAS
TITLE: BIXMODEM.INC
{ }
{ }
{ BIXMODEM.INC Ymodem procedures for use with BIX.PAS }
{ }
{ }
{ Program and all Supporting Materials Copyright }
{ (c) 1985 Barry R. Nance }
{ 17 Pease Street }
{ Wilbraham, Massachusetts 01095 }
{ (413) 596-4031 }
{ }
{ }
Var CRCWork : Integer;
CRC : Integer;
Function PartialCrc (OldCRC:Integer; C:Char) : Integer;
{done in 80x8x assembler for speed}
Begin
CRCWork := OldCRC;
INLINE( $8A / $46 / $04 / (* Mov Al,[Bp+4] *)
$8B / $1E / CRCWork / (* Mov Bx,CRCWork *)
$B9 / $08 / $00 / (* Mov Cx,8 *)
{Oloop:} $D0 / $E0 / (* Shl Al,1 *)
$D1 / $D3 / (* Rcl Bx,1 *)
$73 / $04 / (* Jnc Iloop *)
$81 / $F3 / $21 / $10 / (* Xor Bx,$1021 *)
{Iloop:} $E2 / $F4 / (* Loop Oloop *)
$89 / $1E / CRCWork ) (* Mov CRCWork,BX *);
PartialCRC := CRCWork;
End;
Procedure ReceiveXMODEM (XName : Str20);
Const
SOH = #$01;
STX = #$02;
EOT = #$04;
ACK = #$06;
NAK = #$15;
C_Ch = 'C';
Type
YrecDef = Array [1..1024] of Char;
XrecDef = Array [1..128] of Char;
Var
Xrec : XrecDef;
Yrec : YrecDef;
XFile : File of XrecDef;
XSub : Integer;
ErrCnt : Integer;
BlockError : Boolean;
CurrBlock : Integer;
EOTdetected : Boolean;
BlockLength : Integer;
Duplicate : Boolean;
GetOutFlag : Boolean;
FirstNAK : Boolean;
Function Abort : Boolean;
Begin
Abort := False;
If ErrCnt > 10 then
Begin
HighVideo;
Write (^G);
Write (
'Ten errors have occurred on this block. Continue (Y/N)? ');
LowVideo;
Repeat Read(kbd, Key) Until UpCase(Key) in ['N', 'Y'];
Writeln (Key);
If UpCase(Key) = 'N' then
Begin
Abort := True;
GetOutFlag := True;
End
Else
ErrCnt := 0;
End;
End;
Procedure SendNAK;
Begin
PurgeBuffer;
If Duplicate then Exit;
SendChar(NAK);
Writeln ('Requesting re-transmission of block # ', CurrBlock);
ErrCnt := Succ(ErrCnt);
BlockError := True;
End;
Procedure SendACK;
Begin
SendChar(ACK);
ErrCnt := 0;
End;
Procedure ReceiveSOH;
Begin
ReceiveChar (10, Ch, TimedOut);
If Ch = EOT then
Begin
EOTdetected := True;
SendACK;
Exit;
End;
If Ch = C_Ch then
If CurrBlock = 1 then
ReceiveChar (10, Ch, TimedOut);
If TimedOut then
If CurrBlock = 1 then
If FirstNAK then
Begin
FirstNAK := False;
SendChar (NAK);
ReceiveChar (10, Ch, TimedOut);
End;
If (TimedOut)
or
((Ch <> SOH) And (Ch <> STX)) then
Begin
If TimedOut then
Writeln ('Timed out on SOH/STX.')
Else
Writeln ('1st char not SOH/STX.');
SendNAK;
End
Else
If Ch = STX then
BlockLength := 1024
Else
BlockLength := 128;
End;
Procedure ReceiveBlockNum;
Var Blk : Byte;
PrevBlk : Byte;
FirstCh : Char;
Begin
If BlockError then Exit;
Duplicate := False;
Blk := CurrBlock Mod 256;
PrevBlk := (CurrBlock - 1) Mod 256;
ReceiveChar (1, Ch, TimedOut);
FirstCh := Ch;
If (TimedOut) or (Ord(Ch) <> Blk) then
If Ord(Ch) <> PrevBlk then
Begin
SendNAK;
If TimedOut then
Writeln ('Timed out on block number.')
Else
Writeln ('Block number error (calcd = ', Blk, ').');
Exit;
End;
ReceiveChar (1, Ch, TimedOut);
Blk := 255 - Blk;
PrevBlk := 255 - PrevBlk;
If (TimedOut) or (Ord(Ch) <> Blk) then
If Ord(Ch) <> PrevBlk then
Begin
SendNAK;
If TimedOut then
Writeln ('Timed out on complement.')
Else
Writeln ('Complement error (calcd = ', Blk, ').');
Exit;
End;
If Ord(Ch) = PrevBlk then
If Ord(FirstCh) = CurrBlock Mod 256 then
Duplicate := True;
End;
Procedure ReceiveDataBlock;
Begin
If BlockError then Exit;
OverrunError := False;
Repeat
XSub := Succ(XSub);
ReceiveChar (1, Ch, TimedOut);
If Not TimedOut then
Begin
Yrec [XSub] := Ch;
If BlockLength = 1024 then
CRC := PartialCRC (CRC, Ch);
End;
Until (TimedOut) or (XSub = BlockLength) or (OverrunError);
If (TimedOut) or (OverrunError) then
Begin
SendNAK;
If TimedOut then
Writeln ('Timed out waiting for data.')
Else
Writeln ('Overrun error occurred.');
OverrunError := False;
End;
End;
Procedure ReceiveCheckSum;
Var ChkSum : Byte;
Begin
If BlockError then Exit;
ReceiveChar (1, Ch, TimedOut);
ChkSum := 0;
For XSub := 1 to 128 Do
ChkSum := ChkSum + Ord(Yrec[XSub]);
If (TimedOut) or (ChkSum <> Ord(Ch)) then
Begin
SendNak;
If TimedOut then
Writeln ('Timed out on checksum.')
Else
Writeln (
'Checksum error (is ', Ord(Ch), '; should be ', ChkSum, ').');
End;
End;
Procedure ReceiveCRC;
Var
CRCin : Integer;
Begin
If BlockError then Exit;
ReceiveChar (1, Ch, TimedOut);
If Not TimedOut then
Begin
CRC := PartialCRC (CRC, Ch);
CRCin := ord(Ch) * 256;
ReceiveChar (1, Ch, TimedOut);
If Not TimedOut then
Begin
CRC := PartialCRC (CRC, Ch);
CRCin := CRCin + ord(Ch);
End;
End;
If (TimedOut) or (CRC <> 0) then
Begin
SendNAK;
If TimedOut then
Writeln ('Timed out on CRC.')
Else
Writeln (
'CRC error (is ', CRCin, '; should be ', CRC, ').');
End;
End;
Procedure GetXMODEMBlock;
Begin
If Keypressed then
Begin
GetKey (Key, Extended);
If Key = Chr(27) then
Begin
GetOutFlag := True;
Exit;
End;
End;
BlockError := False;
ReceiveSOH;
If EOTdetected then Exit;
ReceiveBlockNum;
XSub := 0; CRC := 0;
ReceiveDataBlock;
If BlockLength = 1024 then
ReceiveCRC
Else
ReceiveCheckSum;
If Not BlockError then
Begin
SendACK;
If Not Duplicate then
Begin
Writeln ('Block # ', CurrBlock, ' received.');
If BlockLength = 128 then
Begin
Move (Yrec[1], Xrec[1], 128);
Write (XFile, Xrec);
End
Else
Begin
For XSub := 1 to 8 Do
Begin
Move (Yrec[((XSub - 1) * 128) + 1], Xrec[1], 128);
Write (XFile, Xrec);
End;
End;
CurrBlock := Succ(CurrBlock);
End;
End;
End;
Begin {of ReceiveXMODEM}
If XName = '' then Exit;
Assign (XFile, XName);
Rewrite (XFile);
Writeln ('File ', XName, ' is being received.');
Writeln;
UpdateUART (8, 'N', 1);
PurgeBuffer;
SendChar(C_Ch);
FirstNAK := True;
OverrunError := False;
DoingXMODEM := True;
XSub := 0;
ErrCnt := 0;
CurrBlock := 1;
BlockError := False;
EOTdetected := False;
Duplicate := False;
GetOutFlag := False;
Repeat
GetXMODEMBlock;
Until (Abort) or (EOTdetected) or (GetOutFlag);
If GetOutFlag then
Begin
Close (XFile);
Erase (XFile);
Writeln ('ERROR--reception of ', XName, ' cancelled. File erased.');
End
Else
Begin
Close (XFile);
Writeln;
Writeln (XName, ' successfully received.');
End;
DoingXMODEM:= False;
UpdateUART (7, 'E', 1);
End;