home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / perqb.tar.gz / perqb.tar / pq2lin.pas < prev    next >
Pascal/Delphi Source File  |  1985-06-06  |  18KB  |  604 lines

  1. Module KermitLineIO;
  2.  
  3. { This module contains routines to manage the RS232 communication port:
  4. { Character and packet level IO, status management etc. }
  5.  
  6. {=============================} Exports {====================================}
  7.     
  8. imports KermitGlobals from KermitGlobals;
  9.  
  10. const
  11.  
  12.     R4AndAbove  = False;    { Conditional compilation switch: }
  13.                             { Generate versions for R.4, R.5 etc. }
  14.     DelayTime   =  0.01;    { length of delay interval 10 ms }
  15.  
  16. { -- Status and parameter maintenance -- }
  17.     
  18.     procedure InitLine;
  19.     procedure CleanupLine;
  20.     procedure RefreshParity;
  21.     procedure RefreshBaud;
  22.     procedure RefreshStopBits;
  23.     procedure ShowStatus;
  24.  
  25. { -- Miscellaneous utilities -- }
  26.  
  27.     procedure FlushBuffer( Idev : integer );
  28.     procedure SetTimer( Time : integer );
  29.  
  30. { -- Character level IO routines -- }
  31.  
  32.     procedure Outbt( Odev : integer; Ch : char );
  33.     function  GetChar( Idev : integer; var InCh : char ) : boolean;
  34.     function  Inbt( Idev : integer ) : char;
  35.     procedure SendBreak( NumMSecs : integer );
  36.  
  37. { -- Packet level IO routines -- }
  38.  
  39.     procedure   SendPacket ( sptype : PacketType;
  40.                              num    : integer;
  41.                              len    : integer;
  42.                          VAR data   : Packet );
  43.  
  44.     function    ReadPacket (    var num  : integer;
  45.                                 var len  : integer;
  46.                                 var data : Packet  ) : PacketType;
  47.  
  48.     exception   IOWrErr( IOStatus : integer );  { Write or read error }
  49.     exception   IORdErr( IOStatus : integer );  { during OUTBT/INBT }
  50.     exception   BadIdev( Idev : integer );
  51.     exception   TimeOutExit; { Inbt timed out }
  52.     exception   BadChar;     { Is raised when a character which is not a SOH }
  53.                         { or a printable data character is encountered. }
  54.                         { Must be handled by a "do nothing" handler if INBT }
  55.                         { is to be used as a general purpose character input }
  56.                         { routine. }
  57.  
  58.  
  59. {===========================} Private  {====================================}
  60.  
  61. const
  62.     CountDwn    =    45;    { countdown for 10 ms DelayTime, will have to
  63.                                be adjusted if Inbt is modified }
  64.  
  65. imports KermitParameters from KermitParameters;
  66. imports KermitScreen from KermitScreen;
  67.  
  68. imports IOErrMessages from IOErrMessages;
  69. imports IOErrors from IOErrors;
  70. imports IO_Unit from IO_Unit;
  71. imports Screen from Screen;
  72. imports IO_Others from IO_Others;                              
  73. imports IO_Private from IO_Private;
  74. imports UtilProgress from UtilProgress;
  75.  
  76. {************************** Status and parameters ************************} 
  77.  
  78. var InitRSI,InitRSO,RSStatus : DevStatusBlock;
  79.  
  80.  
  81. procedure  InitLine;
  82. begin
  83.     Idev := RS232In;
  84.     Odev := RS232Out;
  85.     Parity := EvenKparity;
  86.     Baud := Sp4800;
  87.     StopBits := Stop2Cmd;
  88.     IOGetStatus( RS232Out, InitRSO);
  89.     IOGetStatus( RS232In,  InitRSI);
  90.     with RSStatus do
  91.     begin
  92.         ByteCnt     := 3;
  93.         RSRcvEnable := true;
  94.         RSFill      := 0;
  95.         RSSpeed     := RS4800;
  96.         RSParity    := EvenParity;
  97.         RSStopBits  := Stop2;
  98.         RSXmitBits  := Send7;
  99.         RSRcvBits   := Rcv7;
  100.     end;
  101.     IOPutStatus(RS232Out,RSStatus);
  102.     IOPutStatus(RS232In,RSStatus);
  103.     ShowStatus;
  104. end; { InitLine }
  105.  
  106. {==========================================================================}
  107.  
  108. procedure  CleanupLine;
  109. begin
  110.     IOPutStatus(RS232Out, InitRSO);
  111.     IOPutStatus(RS232In,  InitRSI);
  112. end;
  113.  
  114. {==========================================================================}
  115.  
  116. procedure RefreshParity;
  117.  
  118.     procedure SetNoParity;
  119.     begin
  120.         with RSStatus do begin
  121.             RSXmitBits := Send8;
  122.             RSRcvBits  := Rcv8;
  123.             RSParity   := NoParity;
  124.         end;
  125.     end;
  126.  
  127.     procedure SetEvenParity;
  128.     begin
  129.         with RSStatus do begin
  130.             RSXmitBits := Send7;
  131.             RSRcvBits  := Rcv7;
  132.             RSParity   := EvenParity;
  133.         end;
  134.     end;
  135.  
  136.     procedure SetOddParity;
  137.     begin
  138.         with RSStatus do begin
  139.             RSXmitBits := Send7;
  140.             RSRcvBits  := Rcv7;
  141.             RSParity   := OddParity;
  142.         end;
  143.     end; 
  144.  
  145.     procedure SetMarkParity;
  146.     begin
  147.         with RSStatus do begin
  148.             RSXmitBits := Send8;
  149.             RSRcvBits  := Rcv8;
  150.             RSParity   := NoParity;
  151.         end;
  152.     end;
  153.  
  154.     procedure SetSpaceParity;
  155.     begin
  156.         with RSStatus do begin
  157.             RSXmitBits := Send8;
  158.             RSRcvBits  := Rcv8;
  159.             RSParity   := NoParity;
  160.         end;
  161.     end;
  162.  
  163. begin
  164.     case Parity of
  165.         NoParComm       :   ;   
  166.         NoKParity       :   SetNoParity;
  167.         OddKParity      :   SetOddParity;
  168.         EvenKParity     :   SetEvenParity;
  169.         MarkKParity     :   SetMarkParity;
  170.         SpaceKParity    :   SetSpaceParity;
  171.     end;
  172.     IOPutStatus(RS232In,RSStatus);
  173.     IOPutStatus(RS232Out,RSStatus);
  174.     ShowStatus;
  175. end; { RefreshParity }
  176.  
  177. {==========================================================================}
  178.  
  179. procedure RefreshBaud;
  180. begin
  181.     with RSStatus do
  182.     case Baud of
  183.         SP110   :   RSSpeed := RS110;
  184.         SP150   :   RSSpeed := RS150;
  185.         SP300   :   RSSpeed := RS300;
  186.         SP600   :   RSSpeed := RS600;
  187.         SP1200  :   RSSpeed := RS1200;
  188.         SP2400  :   RSSpeed := RS2400;
  189.         SP4800  :   RSSpeed := RS4800;
  190.         SP9600  :   RSSpeed := RS9600;
  191.         NoSpeed :   ;
  192.     end;
  193.     IOPutStatus(RS232In,RSStatus);
  194.     IOPutStatus(RS232Out,RSStatus);
  195.     ShowStatus;
  196. end;  { RefreshBaud }
  197.  
  198. {==========================================================================}
  199.  
  200. procedure RefreshStopBits;
  201. begin
  202.     with RSStatus do
  203.     case StopBits of
  204.         SyncrCmd:   RSStopBits := Syncr;
  205.         Stop1Cmd:   RSStopBits := Stop1;
  206.         Stop1x5Cmd: RSStopBits := Stop1x5;
  207.         Stop2Cmd:   RSStopBits := Stop2;
  208.         otherwise:  ;
  209.     end;
  210.     IOPutStatus( RS232In, RSStatus );
  211.     IOPutStatus( RS232Out, RSStatus );
  212.     ShowStatus;
  213. end;    { RefreshStopBits }
  214.  
  215. {==========================================================================}
  216.                
  217. procedure   ShowStatus;
  218. var OldWindow   : WinType;
  219. begin
  220.     CurrentWindow( OldWindow );
  221.     SwitchWindow( StatusWindow );
  222.     with RSStatus do
  223.     begin
  224.         SPutChr(FF);  {   clear window    }
  225.         writeln;
  226.         write('   Speed     = ');
  227.         case RSSpeed of
  228.             RS110    :  write(' 110');
  229.             RS150    :  write(' 150');
  230.             RS300    :  write(' 300');
  231.             RS600    :  write(' 600');
  232.             RS1200   :  write('1200');
  233.             RS2400   :  write('2400');
  234.             RS4800   :  write('4800');
  235.             RS9600   :  write('9600');
  236.         end;
  237.         writeln(' baud');
  238.         write('   Parity    = ');
  239.         case RSParity of
  240.             NoParity    :   write('None ');
  241.             OddParity   :   write('Odd  ');
  242.             IllegParity :   write('Illeg');
  243.             EvenParity  :   write('Even ');
  244.         end;
  245.         writeln;
  246.         write('   Send bits = ');
  247.         case RSXMitBits of
  248.             Send5   :   write('5');
  249.             Send7   :   write('7');
  250.             Send6   :   write('6');
  251.             Send8   :   write('8');
  252.         end;
  253.         writeln;
  254.         write('   Rcv. bits = ');
  255.         case RSRcvBits of
  256.             Rcv5    :   write('5');
  257.             Rcv7    :   write('7');
  258.             Rcv6    :   write('6');
  259.             Rcv8    :   write('8');
  260.         end;                     
  261.         writeln;
  262.         write('   Stop bits = ');
  263.         case RSStopBits of
  264.             Syncr   :   write('Syncr. (No stop bits)');
  265.             Stop1   :   write('1');
  266.             Stop1x5 :   write('1.5');
  267.             Stop2   :   write('2');
  268.         end;    
  269.     end;
  270.     SwitchWindow( OldWindow );
  271. end;
  272.  
  273. {==========================================================================}
  274. {************************* Utilities **************************************}
  275.  
  276. procedure FlushBuffer( Idev : integer );
  277. var dummy : char;
  278.     Istat : integer;
  279. begin 
  280.     repeat
  281.         Istat := IOCRead( Idev, dummy );
  282.         if not (Istat in [IOEIOC,IOEIOB]) then begin
  283.             DbgWrite( 'Unexpected read error on flush of input buffer:' ); 
  284.             DbgInt( Istat );
  285.             DbgNL;
  286.             DbgWrite( IOErrString( Istat ) );
  287.             DbgNL;
  288.             raise IORdErr( Istat );
  289.         end;
  290.     until Istat=IOEIOB;
  291. end;
  292.  
  293. {==========================================================================}
  294.  
  295. var TimeCounter, NumIntval  : integer;
  296.  
  297.  
  298. procedure SetTimer( Time : integer );
  299.  
  300. { Set up timeout counters:  Will generate timeout after Inbt has 
  301.   been called repeatedly for about <Time> seconds }
  302. begin
  303.     TimeCounter := CountDwn;
  304.     NumIntval := Time;
  305. end;
  306.  
  307. {==========================================================================}
  308. {************************ Character level IO ******************************}
  309.  
  310.  
  311. procedure Outbt ( Odev : integer; Ch: char );
  312. { output a character to Odev, raise an exception if error return status }
  313. var IOStatus : integer;
  314. begin
  315.     repeat
  316.         if Parity=SpaceKParity then
  317.             Ch := Chr( LAnd( ord( Ch ), #177 ) )
  318.         else if Parity=MarkKParity then
  319.             Ch := Chr( LOr ( ord( Ch ), #200 ) );
  320.  
  321.         IOStatus := IOCWrite( Odev, Ch );
  322.         if not ( IOStatus in [ IOEIOC, IOECBF ]  ) then
  323.             raise IOWrErr( IOStatus );
  324.     until IOStatus=IOEIOC;
  325. end;
  326.  
  327. {==========================================================================}
  328.  
  329.  
  330. function GetChar( Idev : integer; var InCh : char ) : boolean;
  331.  
  332. var IOStatus : integer; 
  333.     tch      : char;
  334.     C        : record  case boolean of
  335.                    false : ( h  : char );
  336.                    true  : ( BI : CirBufItem)
  337.                end;
  338. begin 
  339.  
  340. { Bug in IOCRead - parameter returned is not always type char }
  341. {  - that's reason why the weird record variable C is used. }
  342.     IOStatus := IOCRead( idev, C.h );
  343.  
  344. { The value returned seems to be of type CirBufItem, but I'm not quite }
  345. { sure whether the error flags REALLY reflects error situations. }
  346.  
  347.         {$IFC R4AndAbove THEN}
  348.     if (C.BI.Status<>0) or
  349.         {$ELSEC}
  350.     if C.BI.RSIError or
  351.         {$ENDC}
  352.        not ( IOStatus in [ IOEIOC, IOEIOB ] ) then begin
  353.         raise IORdErr( IOStatus );
  354.         C.BI.ch := chr(0);  { return from handler: means we   }
  355.         IOStatus := IOEIOC; { ignore errors, ASCII NUL should } 
  356.     end;                    { be harmless to return from INBT }
  357.  
  358.     case IOStatus of
  359.  
  360.         IOEIOC:  { got a character }
  361.             begin
  362.  
  363.                 GetChar := true;
  364.                 tch  := chr( Land( 127, ord( C.BI.ch ) ) );
  365.                 if Parity=NoKParity then
  366.                     InCh := C.BI.ch
  367.                 else
  368.                     InCh := tch;
  369.     
  370.                 if ( ( ord( C.BI.ch )>127 ) AND ( Parity=SpaceKParity ) )  OR
  371.                   ( ( ord( C.BI.ch )<128 ) AND ( Parity=MarkKParity ) ) then
  372.                      raise IORdErr( IOEDAC );
  373.             end;
  374.  
  375.         IOEIOB:  { No character yet available }
  376.             begin
  377.                 GetChar := false;
  378.                 InCh := chr(0);
  379.             end;
  380.  
  381.         otherwise:  { shouldn't happen }
  382.             begin
  383.                 raise IORdErr( IOStatus );
  384.                 GetChar := false;
  385.                 InCh := chr(0);
  386.             end;
  387.     end;
  388. end;
  389.  
  390. {=============================================================================}
  391.  
  392. function Inbt( Idev: integer ) : char;
  393. { Read a character from input device, raise TimeOutExit when timed out }
  394. { NB!!!! To achieve the correct timeout interval, the CONST CountDwn in
  395.    PROCEDURE SetTimer will have to be adjusted if ReadPacket, and especially 
  396.    this function is modified!! }
  397. var  InCh, tch : char;
  398. begin
  399.     while not GetChar( Idev, InCh ) do begin
  400.         TimeCounter := TimeCounter - 1;
  401.         if TimeCounter<=0 then begin
  402.             ShowProgress( ProgressLines );
  403.             NumIntval := NumIntval - 1;
  404.             TimeCounter := CountDwn;
  405.             if NumIntval<=0 then
  406.                 raise TimeOutExit;
  407.         end;                     
  408.     end;  { gotcha!!! }
  409.  
  410.     tch := chr( LAnd( ord(InCh), #177 ) );
  411.     if ( (tch<>RecSOH) AND ( (tch<' ') OR (tch>'~') ) ) then 
  412.         raise BadChar;
  413.     
  414.     inbt := InCh;
  415.  
  416. end;
  417.  
  418.  
  419. {==========================================================================}
  420.  
  421. procedure   SendBreak( NumMSecs : integer );
  422. var SB1, SB2    : DevStatusBlock;
  423.     i           : integer;
  424. begin
  425.     IOGetStatus( RS232Out, SB1 ); 
  426.     SB2 := SB1;
  427.  
  428.     SB2.RSSpeed := RS1200;              { Attempt to generate break by }
  429.     SB2.RSStopBits := Syncr;            { sending a lot of zeroes in   }
  430.     SB2.RSXMitBits := Send5;            { synchronous mode.            }
  431.     IOPutStatus( RS232Out, SB2 );
  432.     for i := 1 to round( NumMSecs*1200 / 5 ) do         { Best we can do! }
  433.         repeat
  434.         until IOCWrite( RS232Out, chr(0) ) = IOEIOC;
  435.  
  436.     IOPutStatus( RS232Out, SB1 );
  437. end;
  438.  
  439.  
  440.  
  441. {==========================================================================}
  442. {************************ Packet level I/O ********************************}
  443.  
  444.  
  445. procedure   WritePacket ( VAR  data : Packet );
  446. { procedure to do the actual IO, assume packet is OK }
  447. var     i : integer;
  448. begin
  449.     for i := 1 to SendNPad do
  450.         outbt ( odev , SendPadChar );
  451.     with data do begin
  452.         outbt ( odev , mark );
  453.         outbt ( odev , count );
  454.         outbt ( odev , seq );
  455.         outbt ( odev , ptype );
  456.         for i := 1  to  ord ( UnChar ( count ) ) - 2 do  
  457.             { NB! output checksum, too }
  458.             outbt ( odev , data[i] );
  459.         outbt ( odev , SendEOL );   { packet-terminator }
  460.     end;
  461. end;
  462.  
  463. {==========================================================================}
  464.  
  465. procedure   SendPacket ( sptype : PacketType;
  466.                          num    : integer;
  467.                          len    : integer;
  468.                      VAR data   : Packet );
  469.  
  470. { build header, calculate checksum and send packet on output-device }
  471. var     i, chksum : integer;
  472.  
  473. begin   { SendPacket }
  474.     if SPType = NAKPack then
  475.         LastNAK := Num
  476.     else
  477.         LastNak := -1;
  478.     with data do begin
  479.         mark := SendSOH;
  480.         if len>=0 then
  481.             count := ToChar ( chr ( len + 3 ) )
  482.         else
  483.             len   := ord ( UnChar ( count ) ) - 3 ;
  484.         adjust( data, len+1 );
  485.         chksum := ord ( count );
  486.         if num>=0 then
  487.             seq := ToChar ( chr ( num ) );
  488.         chksum := chksum + ord ( seq );
  489.         if sptype<>NoChangePack then
  490.             ptype := PackToCh( sptype );
  491.         chksum := chksum + ord ( ptype );
  492.         for i := 1 to len do
  493.             { accumulate checksum }
  494.             chksum := chksum + ord ( data[i] );
  495.         data[len + 1] := MakeCheck ( chksum );
  496.     end;  { with }
  497.     WritePacket ( data );
  498.     if Debug then
  499.         DbgShowPacket ( data );
  500. end;
  501.  
  502. {==========================================================================}
  503.  
  504. function    ReadPacket (    var num  : integer;
  505.                             var len  : integer;
  506.                             var data : Packet  ) : PacketType;
  507.  
  508. { read a packet and return seq. number, data packet and length }
  509. var     chksum,NumIntval,TimeCounter,i        : integer;
  510.         done,ReSynch                          : boolean;
  511.         ch                                    : char;
  512.         PType                                 : PacketType;
  513.   
  514.     handler BadChar;
  515.     begin
  516.         ReadPacket := ChkIllPack;
  517.         exit( ReadPacket );
  518.     end;
  519.  
  520.     handler TimeOutExit;
  521.     begin
  522.         ReadPacket := TimOutPack;
  523.         if not DisableTimOut then
  524.             exit( ReadPacket );
  525.     end;
  526.    
  527.     handler IORdErr( IOStatus : integer );
  528.     begin     { Will be raised if parity errors, overrun, line break etc. }
  529.         raise BadChar;  { Make it synonymous to BadChar in this case }
  530.     end;
  531.     
  532.     procedure WaitForSOH;
  533.     { Gobble anything which is not SOH .... }
  534.     var ch : char;
  535.  
  536.         handler BadChar;
  537.         begin  { .... including bad characters }
  538.         end;
  539.         
  540.     begin
  541.         repeat
  542.             ch := inbt ( idev ) ;
  543.         until (ch = RecSOH);
  544.     end;
  545.  
  546. begin
  547.     SetTimer( trunc(SendTimeOut/DelayTime) );  
  548.     WaitForSOH;
  549.  
  550.     data.mark := RecSOH;
  551.     done := false;
  552.     while not done do
  553.     begin
  554.         ch := inbt ( idev );
  555.         if ch <> RecSOH then   { resynch on SOH }
  556.         begin
  557.             chksum := ord ( ch );
  558.             len    := ord( UnChar ( ch ) ) - 3;
  559.             adjust( data.data, len+1 );   { allowing for checksum, too }
  560.             data.count := ch;
  561.             ch := inbt ( idev );
  562.             if ch <> RecSOH then   { resynch on SOH }
  563.             begin
  564.                 chksum := chksum + ord ( ch );
  565.                 num := ord( UnChar ( ch ) );
  566.                 data.seq := ch;
  567.                 ch := inbt ( idev );
  568.                 if ch <> RecSOH then   { resynch on SOH }
  569.                 begin
  570.                     chksum := chksum + ord ( ch );
  571.                     ReadPacket := ChToPack ( ch );
  572.                     data.ptype := ch;
  573.                     i := 1;
  574.                     ReSynch := FALSE;
  575.                     while not ((i>len) or ReSynch) do begin
  576.                         ch := inbt ( idev );
  577.                         ReSynch := ch=RecSOH;
  578.                         if not ReSynch then
  579.                         begin
  580.                             chksum := chksum + ord ( ch );
  581.                             data.data[i] := ch;
  582.                         end;
  583.                         i := i + 1;
  584.                     end;
  585.                     if not ReSynch then
  586.                     begin
  587.                         ch := inbt ( idev );
  588.                         data.data[i] := ch;
  589.                         if ( MakeCheck ( chksum ) <> ch )
  590.                            and ( ch <> RecSOH )
  591.                         then
  592.                             ReadPacket := ChkIllPack;
  593.                         done := ch <> RecSOH;
  594.                     end;
  595.                 end;
  596.             end;
  597.         end;
  598.     end;
  599.     FlushBuffer(Idev);  { nothing more - does never stack packets }
  600.     if Debug then
  601.          DbgShowPacket( data );
  602.    
  603. end.
  604.