Columbia Kermit/kermit.zip/perqb/pq2lin.pas

Pascal/Delphi Source File | 2020-01-01 | 18KB | 604 lines

Module KermitLineIO;

{ This module contains routines to manage the RS232 communication port:
{ Character and packet level IO, status management etc. }

{=============================} Exports {====================================}

imports KermitGlobals from KermitGlobals;

const

    R4AndAbove  = False;    { Conditional compilation switch: }
                            { Generate versions for R.4, R.5 etc. }
    DelayTime   =  0.01;    { length of delay interval 10 ms }

{ -- Status and parameter maintenance -- }

    procedure InitLine;
    procedure CleanupLine;
    procedure RefreshParity;
    procedure RefreshBaud;
    procedure RefreshStopBits;
    procedure ShowStatus;

{ -- Miscellaneous utilities -- }

    procedure FlushBuffer( Idev : integer );
    procedure SetTimer( Time : integer );

{ -- Character level IO routines -- }

    procedure Outbt( Odev : integer; Ch : char );
    function  GetChar( Idev : integer; var InCh : char ) : boolean;
    function  Inbt( Idev : integer ) : char;
    procedure SendBreak( NumMSecs : integer );

{ -- Packet level IO routines -- }

    procedure   SendPacket ( sptype : PacketType;
                             num    : integer;
                             len    : integer;
                         VAR data   : Packet );

    function    ReadPacket (    var num  : integer;
                                var len  : integer;
                                var data : Packet  ) : PacketType;

    exception   IOWrErr( IOStatus : integer );  { Write or read error }
    exception   IORdErr( IOStatus : integer );  { during OUTBT/INBT }
    exception   BadIdev( Idev : integer );
    exception   TimeOutExit; { Inbt timed out }
    exception   BadChar;     { Is raised when a character which is not a SOH }
                        { or a printable data character is encountered. }
                        { Must be handled by a "do nothing" handler if INBT }
                        { is to be used as a general purpose character input }
                        { routine. }


{===========================} Private  {====================================}

const
    CountDwn    =    45;    { countdown for 10 ms DelayTime, will have to
                               be adjusted if Inbt is modified }

imports KermitParameters from KermitParameters;
imports KermitScreen from KermitScreen;

imports IOErrMessages from IOErrMessages;
imports IOErrors from IOErrors;
imports IO_Unit from IO_Unit;
imports Screen from Screen;
imports IO_Others from IO_Others;
imports IO_Private from IO_Private;
imports UtilProgress from UtilProgress;

{************************** Status and parameters ************************}

var InitRSI,InitRSO,RSStatus : DevStatusBlock;


procedure  InitLine;
begin
    Idev := RS232In;
    Odev := RS232Out;
    Parity := EvenKparity;
    Baud := Sp4800;
    StopBits := Stop2Cmd;
    IOGetStatus( RS232Out, InitRSO);
    IOGetStatus( RS232In,  InitRSI);
    with RSStatus do
    begin
        ByteCnt     := 3;
        RSRcvEnable := true;
        RSFill      := 0;
        RSSpeed     := RS4800;
        RSParity    := EvenParity;
        RSStopBits  := Stop2;
        RSXmitBits  := Send7;
        RSRcvBits   := Rcv7;
    end;
    IOPutStatus(RS232Out,RSStatus);
    IOPutStatus(RS232In,RSStatus);
    ShowStatus;
end; { InitLine }

{==========================================================================}

procedure  CleanupLine;
begin
    IOPutStatus(RS232Out, InitRSO);
    IOPutStatus(RS232In,  InitRSI);
end;

{==========================================================================}

procedure RefreshParity;

    procedure SetNoParity;
    begin
        with RSStatus do begin
            RSXmitBits := Send8;
            RSRcvBits  := Rcv8;
            RSParity   := NoParity;
        end;
    end;

    procedure SetEvenParity;
    begin
        with RSStatus do begin
            RSXmitBits := Send7;
            RSRcvBits  := Rcv7;
            RSParity   := EvenParity;
        end;
    end;

    procedure SetOddParity;
    begin
        with RSStatus do begin
            RSXmitBits := Send7;
            RSRcvBits  := Rcv7;
            RSParity   := OddParity;
        end;
    end;

    procedure SetMarkParity;
    begin
        with RSStatus do begin
            RSXmitBits := Send8;
            RSRcvBits  := Rcv8;
            RSParity   := NoParity;
        end;
    end;

    procedure SetSpaceParity;
    begin
        with RSStatus do begin
            RSXmitBits := Send8;
            RSRcvBits  := Rcv8;
            RSParity   := NoParity;
        end;
    end;

begin
    case Parity of
        NoParComm       :   ;
        NoKParity       :   SetNoParity;
        OddKParity      :   SetOddParity;
        EvenKParity     :   SetEvenParity;
        MarkKParity     :   SetMarkParity;
        SpaceKParity    :   SetSpaceParity;
    end;
    IOPutStatus(RS232In,RSStatus);
    IOPutStatus(RS232Out,RSStatus);
    ShowStatus;
end; { RefreshParity }

{==========================================================================}

procedure RefreshBaud;
begin
    with RSStatus do
    case Baud of
        SP110   :   RSSpeed := RS110;
        SP150   :   RSSpeed := RS150;
        SP300   :   RSSpeed := RS300;
        SP600   :   RSSpeed := RS600;
        SP1200  :   RSSpeed := RS1200;
        SP2400  :   RSSpeed := RS2400;
        SP4800  :   RSSpeed := RS4800;
        SP9600  :   RSSpeed := RS9600;
        NoSpeed :   ;
    end;
    IOPutStatus(RS232In,RSStatus);
    IOPutStatus(RS232Out,RSStatus);
    ShowStatus;
end;  { RefreshBaud }

{==========================================================================}

procedure RefreshStopBits;
begin
    with RSStatus do
    case StopBits of
        SyncrCmd:   RSStopBits := Syncr;
        Stop1Cmd:   RSStopBits := Stop1;
        Stop1x5Cmd: RSStopBits := Stop1x5;
        Stop2Cmd:   RSStopBits := Stop2;
        otherwise:  ;
    end;
    IOPutStatus( RS232In, RSStatus );
    IOPutStatus( RS232Out, RSStatus );
    ShowStatus;
end;    { RefreshStopBits }

{==========================================================================}

procedure   ShowStatus;
var OldWindow   : WinType;
begin
    CurrentWindow( OldWindow );
    SwitchWindow( StatusWindow );
    with RSStatus do
    begin
        SPutChr(FF);  {   clear window    }
        writeln;
        write('   Speed     = ');
        case RSSpeed of
            RS110    :  write(' 110');
            RS150    :  write(' 150');
            RS300    :  write(' 300');
            RS600    :  write(' 600');
            RS1200   :  write('1200');
            RS2400   :  write('2400');
            RS4800   :  write('4800');
            RS9600   :  write('9600');
        end;
        writeln(' baud');
        write('   Parity    = ');
        case RSParity of
            NoParity    :   write('None ');
            OddParity   :   write('Odd  ');
            IllegParity :   write('Illeg');
            EvenParity  :   write('Even ');
        end;
        writeln;
        write('   Send bits = ');
        case RSXMitBits of
            Send5   :   write('5');
            Send7   :   write('7');
            Send6   :   write('6');
            Send8   :   write('8');
        end;
        writeln;
        write('   Rcv. bits = ');
        case RSRcvBits of
            Rcv5    :   write('5');
            Rcv7    :   write('7');
            Rcv6    :   write('6');
            Rcv8    :   write('8');
        end;
        writeln;
        write('   Stop bits = ');
        case RSStopBits of
            Syncr   :   write('Syncr. (No stop bits)');
            Stop1   :   write('1');
            Stop1x5 :   write('1.5');
            Stop2   :   write('2');
        end;
    end;
    SwitchWindow( OldWindow );
end;

{==========================================================================}
{************************* Utilities **************************************}

procedure FlushBuffer( Idev : integer );
var dummy : char;
    Istat : integer;
begin
    repeat
        Istat := IOCRead( Idev, dummy );
        if not (Istat in [IOEIOC,IOEIOB]) then begin
            DbgWrite( 'Unexpected read error on flush of input buffer:' );
            DbgInt( Istat );
            DbgNL;
            DbgWrite( IOErrString( Istat ) );
            DbgNL;
            raise IORdErr( Istat );
        end;
    until Istat=IOEIOB;
end;

{==========================================================================}

var TimeCounter, NumIntval  : integer;


procedure SetTimer( Time : integer );

{ Set up timeout counters:  Will generate timeout after Inbt has
  been called repeatedly for about <Time> seconds }
begin
    TimeCounter := CountDwn;
    NumIntval := Time;
end;

{==========================================================================}
{************************ Character level IO ******************************}


procedure Outbt ( Odev : integer; Ch: char );
{ output a character to Odev, raise an exception if error return status }
var IOStatus : integer;
begin
    repeat
        if Parity=SpaceKParity then
            Ch := Chr( LAnd( ord( Ch ), #177 ) )
        else if Parity=MarkKParity then
            Ch := Chr( LOr ( ord( Ch ), #200 ) );

        IOStatus := IOCWrite( Odev, Ch );
        if not ( IOStatus in [ IOEIOC, IOECBF ]  ) then
            raise IOWrErr( IOStatus );
    until IOStatus=IOEIOC;
end;

{==========================================================================}


function GetChar( Idev : integer; var InCh : char ) : boolean;

var IOStatus : integer;
    tch      : char;
    C        : record  case boolean of
                   false : ( h  : char );
                   true  : ( BI : CirBufItem)
               end;
begin

{ Bug in IOCRead - parameter returned is not always type char }
{  - that's reason why the weird record variable C is used. }
    IOStatus := IOCRead( idev, C.h );

{ The value returned seems to be of type CirBufItem, but I'm not quite }
{ sure whether the error flags REALLY reflects error situations. }

        {$IFC R4AndAbove THEN}
    if (C.BI.Status<>0) or
        {$ELSEC}
    if C.BI.RSIError or
        {$ENDC}
       not ( IOStatus in [ IOEIOC, IOEIOB ] ) then begin
        raise IORdErr( IOStatus );
        C.BI.ch := chr(0);  { return from handler: means we   }
        IOStatus := IOEIOC; { ignore errors, ASCII NUL should }
    end;                    { be harmless to return from INBT }

    case IOStatus of

        IOEIOC:  { got a character }
            begin

                GetChar := true;
                tch  := chr( Land( 127, ord( C.BI.ch ) ) );
                if Parity=NoKParity then
                    InCh := C.BI.ch
                else
                    InCh := tch;

                if ( ( ord( C.BI.ch )>127 ) AND ( Parity=SpaceKParity ) )  OR
                  ( ( ord( C.BI.ch )<128 ) AND ( Parity=MarkKParity ) ) then
                     raise IORdErr( IOEDAC );
            end;

        IOEIOB:  { No character yet available }
            begin
                GetChar := false;
                InCh := chr(0);
            end;

        otherwise:  { shouldn't happen }
            begin
                raise IORdErr( IOStatus );
                GetChar := false;
                InCh := chr(0);
            end;
    end;
end;

{=============================================================================}

function Inbt( Idev: integer ) : char;
{ Read a character from input device, raise TimeOutExit when timed out }
{ NB!!!! To achieve the correct timeout interval, the CONST CountDwn in
   PROCEDURE SetTimer will have to be adjusted if ReadPacket, and especially
   this function is modified!! }
var  InCh, tch : char;
begin
    while not GetChar( Idev, InCh ) do begin
        TimeCounter := TimeCounter - 1;
        if TimeCounter<=0 then begin
            ShowProgress( ProgressLines );
            NumIntval := NumIntval - 1;
            TimeCounter := CountDwn;
            if NumIntval<=0 then
                raise TimeOutExit;
        end;
    end;  { gotcha!!! }

    tch := chr( LAnd( ord(InCh), #177 ) );
    if ( (tch<>RecSOH) AND ( (tch<' ') OR (tch>'~') ) ) then
        raise BadChar;

    inbt := InCh;

end;


{==========================================================================}

procedure   SendBreak( NumMSecs : integer );
var SB1, SB2    : DevStatusBlock;
    i           : integer;
begin
    IOGetStatus( RS232Out, SB1 );
    SB2 := SB1;

    SB2.RSSpeed := RS1200;              { Attempt to generate break by }
    SB2.RSStopBits := Syncr;            { sending a lot of zeroes in   }
    SB2.RSXMitBits := Send5;            { synchronous mode.            }
    IOPutStatus( RS232Out, SB2 );
    for i := 1 to round( NumMSecs*1200 / 5 ) do         { Best we can do! }
        repeat
        until IOCWrite( RS232Out, chr(0) ) = IOEIOC;

    IOPutStatus( RS232Out, SB1 );
end;



{==========================================================================}
{************************ Packet level I/O ********************************}


procedure   WritePacket ( VAR  data : Packet );
{ procedure to do the actual IO, assume packet is OK }
var     i : integer;
begin
    for i := 1 to SendNPad do
        outbt ( odev , SendPadChar );
    with data do begin
        outbt ( odev , mark );
        outbt ( odev , count );
        outbt ( odev , seq );
        outbt ( odev , ptype );
        for i := 1  to  ord ( UnChar ( count ) ) - 2 do
            { NB! output checksum, too }
            outbt ( odev , data[i] );
        outbt ( odev , SendEOL );   { packet-terminator }
    end;
end;

{==========================================================================}

procedure   SendPacket ( sptype : PacketType;
                         num    : integer;
                         len    : integer;
                     VAR data   : Packet );

{ build header, calculate checksum and send packet on output-device }
var     i, chksum : integer;

begin   { SendPacket }
    if SPType = NAKPack then
        LastNAK := Num
    else
        LastNak := -1;
    with data do begin
        mark := SendSOH;
        if len>=0 then
            count := ToChar ( chr ( len + 3 ) )
        else
            len   := ord ( UnChar ( count ) ) - 3 ;
        adjust( data, len+1 );
        chksum := ord ( count );
        if num>=0 then
            seq := ToChar ( chr ( num ) );
        chksum := chksum + ord ( seq );
        if sptype<>NoChangePack then
            ptype := PackToCh( sptype );
        chksum := chksum + ord ( ptype );
        for i := 1 to len do
            { accumulate checksum }
            chksum := chksum + ord ( data[i] );
        data[len + 1] := MakeCheck ( chksum );
    end;  { with }
    WritePacket ( data );
    if Debug then
        DbgShowPacket ( data );
end;

{==========================================================================}

function    ReadPacket (    var num  : integer;
                            var len  : integer;
                            var data : Packet  ) : PacketType;

{ read a packet and return seq. number, data packet and length }
var     chksum,NumIntval,TimeCounter,i        : integer;
        done,ReSynch                          : boolean;
        ch                                    : char;
        PType                                 : PacketType;

    handler BadChar;
    begin
        ReadPacket := ChkIllPack;
        exit( ReadPacket );
    end;

    handler TimeOutExit;
    begin
        ReadPacket := TimOutPack;
        if not DisableTimOut then
            exit( ReadPacket );
    end;

    handler IORdErr( IOStatus : integer );
    begin     { Will be raised if parity errors, overrun, line break etc. }
        raise BadChar;  { Make it synonymous to BadChar in this case }
    end;

    procedure WaitForSOH;
    { Gobble anything which is not SOH .... }
    var ch : char;

        handler BadChar;
        begin  { .... including bad characters }
        end;

    begin
        repeat
            ch := inbt ( idev ) ;
        until (ch = RecSOH);
    end;

begin
    SetTimer( trunc(SendTimeOut/DelayTime) );
    WaitForSOH;

    data.mark := RecSOH;
    done := false;
    while not done do
    begin
        ch := inbt ( idev );
        if ch <> RecSOH then   { resynch on SOH }
        begin
            chksum := ord ( ch );
            len    := ord( UnChar ( ch ) ) - 3;
            adjust( data.data, len+1 );   { allowing for checksum, too }
            data.count := ch;
            ch := inbt ( idev );
            if ch <> RecSOH then   { resynch on SOH }
            begin
                chksum := chksum + ord ( ch );
                num := ord( UnChar ( ch ) );
                data.seq := ch;
                ch := inbt ( idev );
                if ch <> RecSOH then   { resynch on SOH }
                begin
                    chksum := chksum + ord ( ch );
                    ReadPacket := ChToPack ( ch );
                    data.ptype := ch;
                    i := 1;
                    ReSynch := FALSE;
                    while not ((i>len) or ReSynch) do begin
                        ch := inbt ( idev );
                        ReSynch := ch=RecSOH;
                        if not ReSynch then
                        begin
                            chksum := chksum + ord ( ch );
                            data.data[i] := ch;
                        end;
                        i := i + 1;
                    end;
                    if not ReSynch then
                    begin
                        ch := inbt ( idev );
                        data.data[i] := ch;
                        if ( MakeCheck ( chksum ) <> ch )
                           and ( ch <> RecSOH )
                        then
                            ReadPacket := ChkIllPack;
                        done := ch <> RecSOH;
                    end;
                end;
            end;
        end;
    end;
    FlushBuffer(Idev);  { nothing more - does never stack packets }
    if Debug then
         DbgShowPacket( data );

end.