Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/msdos/turbopas/ymodem.arc/YMODEM.PAS

Pascal/Delphi Source File | 1987-10-21 | 10KB | 409 lines

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                }
{               [phone]                                }
{                                                             }
{                                                             }


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;