home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / PCL4P30.ZIP / TERM_IO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-01-18  |  4.3 KB  |  189 lines
  1. (* TERM_IO.PAS *)
  2.  
  3. {  $DEFINE DEBUG}
  4.  
  5. (*********************************************)
  6. (*                                           *)
  7. (*  Used for I/O by TERM.PAS                 *)
  8. (*                                           *)
  9. (*  This program is donated to the Public    *)
  10. (*  Domain by MarshallSoft Computing, Inc.   *)
  11. (*  It is provided as an example of the use  *)
  12. (*  of the Personal Communications Library.  *)
  13. (*                                           *)
  14. (*********************************************)
  15.  
  16.  
  17. unit term_IO;
  18.  
  19. interface
  20.  
  21. type
  22.   String40 = String[40];
  23.   String20 = String[20];
  24.  
  25. Procedure WriteMsg(MsgString:String40; StartCol:Byte);
  26. Procedure ReadMsg(VAR MsgString:String20; StartCol, MaxLength:Byte);
  27. Procedure PutChar(Port:Integer; c:Byte);
  28. Function  GetChar(Port:Integer; Timeout:Integer):Integer;
  29. Procedure SayError(Code:Integer;Message:String40);
  30.  
  31. implementation
  32.  
  33. uses PCL4P,HEX_IO,CRT;
  34.  
  35. const
  36.   CR  : Byte = $0d;
  37.   ESC : Byte = $1B;
  38.   BS  : Byte = $08;
  39.   BLK : Byte = $20;
  40.   CAN : Byte = $18;
  41.  
  42.  
  43. Procedure WriteMsg(MsgString:String40; StartCol:Byte);
  44. var
  45.   i:Integer;
  46.   Row:Byte;
  47.   Col:Byte;
  48. begin
  49.   Col := WhereX;
  50.   Row := WhereY;
  51.   (* goto display window *)
  52.   Window(1,25,80,25);
  53.   HighVideo;
  54.   GotoXY(StartCol,1);
  55.   Write(MsgString);
  56.   for i := Length(MsgString)+1 to 39 do Write(' ');
  57.   (* back to main window *)
  58.   Window(1,1,80,24);
  59.   LowVideo;
  60.   GotoXY(Col,Row);
  61. end;
  62.  
  63.  
  64. Procedure ReadMsg(VAR MsgString:String20; StartCol, MaxLength:Byte);
  65. Label 999;
  66. var
  67.   Row:Byte;
  68.   Col:Byte;
  69.   i  :Byte;
  70.   c  :Char;
  71. begin
  72.   Row := WhereY;
  73.   Col := WhereX;
  74.   (* goto  display window *)
  75.   Window(1,25,80,25);
  76.   HighVideo;
  77.   (* input text from user *)
  78.   i := 0;
  79.   while true do
  80.      begin
  81.        GotoXY(StartCol+i,1);
  82.        c := ReadKey;
  83.        case ord(c) of
  84.          $0D : goto 999;
  85.          $1B : (* Escape *)
  86.            begin
  87.              (* return empty string *)
  88.              i := 0;
  89.              goto 999;
  90.            end;
  91.          $08 : (* backspace *)
  92.            begin
  93.              (* back up if can *)
  94.              if i > 0 then
  95.                begin
  96.                  (* adjust buffer *)
  97.                  i := i - 1;
  98.                  (* write blank at cursor *)
  99.                  GotoXY(StartCol+i,1);
  100.                  write(' ');
  101.                  GotoXY(StartCol+i,1)
  102.                end
  103.            end
  104.        else (* not one of above special chars *)
  105.          begin
  106.            (* save character *)
  107.            i := i + 1;
  108.            MsgString[i] := c;
  109.            (* display on bottom line *)
  110.            Write(c);
  111.            (* done ? *)
  112.            if i = MaxLength then goto 999;
  113.          end
  114.        end (* case *)
  115.      end; (* end while *)
  116. 999:(* set length *)
  117.   MsgString[0] := chr(i);
  118.   (* back to main window *)
  119.   Window(1,1,80,24);
  120.   LowVideo;
  121.   GotoXY(Col,Row);
  122. end;
  123.  
  124. (*** Send character over serial line ***)
  125.  
  126. Procedure PutChar(Port:Integer; C:Byte);
  127. var
  128.   Code:Integer;
  129. begin
  130.   Code := SioPutc(Port,chr(C));
  131.   if Code < 0 then
  132.      begin
  133.        writeln('COM',1+Port,' error');
  134.        Code := SioError(Code);
  135.        Halt;
  136.      end;
  137. {$IFDEF DEBUG}
  138.   if (C < $20) or (C > $7E) then
  139.     begin
  140.       write('[$');
  141.       WriteHexByte(C);
  142.       write(']');
  143.     end
  144.   else write( chr(C) );
  145. {$ENDIF}
  146. end;
  147.  
  148. (*** Receive character from serial line ***)
  149.  
  150. Function GetChar(Port:Integer; Timeout:Integer):Integer;
  151. var
  152.   Code:Integer;
  153. begin
  154.   Code := SioGetc(Port,Timeout);
  155.   if Code < -1 then
  156.     begin
  157.       writeln('COM',1+Port,' error');
  158.       Code := SioError(Code);
  159.       Halt;
  160.     end;
  161. {$IFDEF DEBUG}
  162.   if (Code < $20) or (Code > $7E) then
  163.     begin
  164.       write('($');
  165.       WriteHexByte(Code);
  166.       write(')');
  167.     end
  168.   else write( chr(Code) );
  169. {$ENDIF}
  170.   GetChar := Code;
  171. end;
  172.  
  173. (*** Say error code ***)
  174.  
  175. procedure SayError(Code:Integer;Message:String40);
  176. var
  177.    RetCode:Integer;
  178. begin
  179.    writeln(Message);
  180.    if Code < 0 then RetCode := SioError( Code )
  181.    else if (Code and (FramingError or ParityError or OverrunError)) <> 0 then
  182.       begin (* Port Error *)
  183.          if (Code and FramingError) <> 0 then writeln('Framing Error');
  184.          if (Code and ParityError)  <> 0 then writeln('Parity Error');
  185.          if (Code and OverrunError) <> 0 then writeln('Overrun Error')
  186.       end
  187. end;
  188.  
  189. end.