Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PROT100.ZIP/FOS.PAS

Pascal/Delphi Source File | 1993-03-15 | 12.3 KB | 517 lines

(*
    FOS.PAS - Communications subroutines for the ibm pc
    Fossil.pas (12/24/91)
    Modified Send() to use with Sealink.  Sends CHAR not byte.

FUNCTION  Com_Baud          - Returns baudrate of connection. (getfosinfo 1st)
FUNCTION  Carrier           - Returns status of Carrier on PortNumber.
FUNCTION  CK                - Returns status if user hit Ctrl-C/Ctrl-K.
PROCEDURE CloseFossil       - Terminates output to the Fossil.
FUNCTION  Com_              - General Purpose Comm function.
FUNCTION  Com_Data          - Returns data bits (getfosinfo 1st)
FUNCTION  Com_Parity        - Returns Parity as char (N,E,O) (getfosinfo 1st)
FUNCTION  Com_Stop          - Returns stop bits (getfosinfo 1st)
PROCEDURE Comm_Set_Baud     - Set Baud, Parity, Data Bits, Stop Bits.
FUNCTION  Comm_Transmit     - Returns STATUS bits of a transmit with wait.
PROCEDURE FlushBuff         - Flush Outbound buffer (fossil).
PROCEDURE FlowControl       - Establish flow control.
FUNCTION  FPresent          - Checks if Fossil installed (no init).
PROCEDURE GetFosInfo        - Fills the FosInfo structure variable.
PROCEDURE HangUpPhone       - Hangs up the telephone - fossil.
FUNCTION  KeyChar           - Checks if char is available from keyboard.
PROCEDURE ModemPut          - Sends commands to the modem.  Like BINKLEYTERM
FUNCTION  OpenFossil        - Checks to see if Fossil installed.
FUNCTION  OutEmpty          - Returns TRUE if output buffer is empty.
PROCEDURE PurgeLine         - Purge the receive buffer.
PROCEDURE PurgeOutput       - Purges the output (transmit) buffer.
PROCEDURE ReadBlk           - Reads a block from the communications port.
FUNCTION  ReadLine          - Return ORD of char received or TIMEOUT.
FUNCTION  Receive           - Fossil receive a character.
PROCEDURE Send              - Fossil transfer a character.
PROCEDURE SendBlk           - Send a block of chars through port.
PROCEDURE SendText          - Sends a string to the modem
FUNCTION  SerialChar        - Checks if char is available from PortNum.
PROCEDURE SetBaudRate       - Change baud rate of communications port. N-8-1
PROCEDURE SetCheck          - Turns Ctrl-C/Ctrl-K checking on/off.
PROCEDURE SetDTR            - Toggles status of DTR.
*)

UNIT Fos;

interface

type  FosData = record
         ssize    : word;
         version  : byte;
         revision : byte;
         segment  : word;  { id : longint }
         offset   : word;
         rcvbuf   : word;
         i_avail  : word;
         sndbuf   : word;
         o_avail  : word;
         width    : byte;
         height   : byte;
         baud     : byte;
      end;

const loopspersec = 6500;
      timeout  = 256;

var PortNum : word;
    BaudRate: word;
    Parity  : Char;
    DataBits: Byte;
    StopBits: Byte;
    FosInfo : FosData;
    FossilIDStr : string;

function  carrier : boolean;
function  ck : boolean;
procedure closefossil;
function  com_baud(baud:byte) : word;
function  com_data(baud:byte):byte;
function  com_parity(baud:byte):char;
function  com_stop(baud:byte):byte;
procedure comm_set_baud( baud:word; parity : char; data, stop : byte);
procedure flushbuff;
procedure flowcontrol(kind:byte);
function  fpresent : boolean;
procedure getfosinfo( var fosinfo : fosdata);
procedure hangupphone;
function  keychar : boolean;
procedure modemput(initstr:string);
function  openfossil : boolean;
function  outempty : boolean;
procedure purgeline;
procedure purgeoutput;
procedure readblk(segment,offset,count:word);
function  readline(seconds:integer): integer;
function  receive : char;
procedure send(letter : char);
procedure setbaudrate ( baud : word);
procedure setcheck( on : boolean);
procedure setdtr( a : boolean);
function  serialchar : boolean;
procedure sendtext(initstr : string);
procedure sendblk( Seg_Ment, Off_Set, count:word);

implementation

uses crt,
     dos;

type
    ptrmask = record   { segment:offset mask for address pointers }
       poff : word;
       pseg : word;
    end;

var regs : registers;

{---------------------------- ASCIIZ to string ----------------------------}
function Asc2Str(var s; max: byte): string;
{ Converts an ASCIIZ string to a Turbo Pascal string with a max length: max. }
var starray  : array[1..255] of char absolute s;
    len      : integer;
begin
     len        := pos(#0,starray)-1;                       { Get the length }
     if (len > max) or (len < 0) then               { length exceeds maximum }
       len      := max;                                  { so set to maximum }
     Asc2Str    := starray;
     Asc2Str[0] := chr(len);                                    { Set length }
end;  { Asc2Str }

function com_baud(baud:byte):word;
begin
  baud := baud shr 5;
  case baud of
    $02 : com_baud :=   300;
    $03 : com_baud :=   600;
    $04 : com_baud :=  1200;
    $05 : com_baud :=  2400;
    $06 : com_baud :=  4800;
    $07 : com_baud :=  9600;
    $00 : com_baud := 19200;
    $01 : com_baud := 38400;
  else
    com_baud := 1200;
  end;
end;


function fpresent : boolean;             (* FOSSIL there? *)
Var Int14Vec : Pointer;
begin
  GetIntVec($14, Int14Vec);
  FPresent := (MemW[Seg(Int14Vec^):Ofs(Int14Vec^) + 6] = $1954);
end;


function openfossil : boolean;
begin
  regs.ah := $04;
  regs.dx := PortNum;
  Intr($14,regs); { TPX00( regs) ; }
  OpenFossil := (Regs.AX = $1954);
end;


function ck : boolean;
begin
   ck := FALSE;
   if keypressed then
      ck := (readkey in [#3,#11])
   else if serialchar then ck := (receive in [#3,#11]);
end;


procedure closefossil;
begin
  asm
     mov ah, 5
     mov dx, portnum
     int 14h
  end;
end;


function com_data(baud:byte):byte; { pass it: FossInfo.baud }
var p : boolean;
begin
    p := (baud and $03) = $03;
    if p then com_data := 8 else com_data := 7;
end;


function com_parity(baud:byte):char; { pass it: FossInfo.baud }
var p : boolean;
begin
    p := (baud and $18) = $18;
    if p then com_parity := 'E' else begin
       p := (baud and $08) = $08;
       if p then com_parity := 'O' else com_parity := 'N';
    end;
end;


function com_stop(baud:byte):byte; { pass it: FossInfo.baud }
begin
  com_stop := (baud and $04) + 1;
end;


procedure comm_set_baud( baud : word; parity : char; data, stop : byte);
var value : byte;
begin
   Regs.AH := 0;
   Regs.DX := PortNum;
   value := $60;
   case baud of
       300 : value:=$40;
       600 : value:=$60;
      1200 : value:=$80;
      2400 : value:=$A0;
      4800 : value:=$C0;
      9600 : value:=$E0;
     19200 : value:=$00;
     38400 : value:=$20;
   end;
   case upcase(parity) of
   {  'N': value := value OR $10; }
     'E': value := value + $18;
     'O': value := value + $08;
   end;
   case data of
     7 : value := value + $02;
     8 : value := value + $03;
   end;
   case stop of
     2 : value := value + $04;
   end;
   regs.al := value;
   Intr($14,regs);
end;


procedure flowcontrol(kind:byte);
{
call must be 'intelligent', ie. you know what you want.
things are additive.  bits set  0 - enable remote restraint via xon/xoff
                                1 - cts/rts
                                2 - fossil can restrain remote via xon/xoff
}
begin
   asm
     mov AH, 0FH        { Enable/Disable ComPort Flow Control }
     mov AL, kind       { Type of flow control as above       }
     mov DX, Portnum
     int 14H
   end;
end;


procedure setbaudrate ( baud : word); { issues N-8-1 }
begin
   case baud of
       300 : Regs.AL:=$43;
       600 : Regs.AL:=$63;
      1200 : Regs.AL:=$83;
      2400 : Regs.AL:=$A3;
      4800 : Regs.AL:=$C3;
      9600 : Regs.AL:=$E3;
     19200 : Regs.AL:=$03;
     38400 : Regs.AL:=$23;
   else
      regs.al := $63;
   end;
   regs.ah := $00;
   regs.dx := Portnum;
   Intr($14, regs);
end;


function carrier : boolean;
begin
asm
      mov  dx, PortNum
      mov  ah, 3
      int  14H
      xor  dl, dl
      and  al, 80H
      jz   @2
      inc  dl
@2:   mov  @Result, DL
end;
end;


function keychar : boolean;
begin
  asm
       mov  ah, 0DH
       mov  dx, Portnum
       int  14H
       xor  dl, dl
       inc  ax
       jz   @1
       mov  dl, 1
  @1:  mov @Result, dl
  end;
end;


procedure setdtr( A : Boolean); assembler;
asm
     mov ah, 6
     mov dx, Portnum
     mov al, a
     int 14H
end;


function serialchar : boolean;
begin
   asm
       mov  dx, Portnum
       mov  ah, 0CH
       int  14H          { $FF if no characters }
       xor  dl, dl
       inc  ax
       jz   @l1          { would be zero if no characters here }
       inc  dl           { There is one! }
  @l1: mov  @Result, DL
  end;
end;


function receive : char;
begin
   asm
      mov ah, 2
      mov dx, Portnum
      int 14H
      mov @result, al
   end;
end;


function outempty : boolean;
begin
asm
     mov  ah, 3
     mov  dx, PortNum
     int  14H
     xor  dl, dl
     and  ah, 40H
     jz   @l1
     inc  dl
@l1: mov  @Result, DL
end;
end;


procedure send(Letter : char);
Begin
  while not outempty do;
  asm
       mov AH, 01H
       mov AL, Letter
       mov dx, PortNum
       int 14H
  end;
end;


procedure flushbuff; assembler;
asm
   mov ah, 8
   mov dx, portnum
   int 14h
end;


procedure getfosinfo( var fosinfo : fosdata);
{ Must issue call to OpenFossil before running this procedure.}
var  p    : ^byte;
     s    : string;
begin
   regs.ah := $1B;
   regs.cx := SizeOf(fosinfo);
   regs.es := Seg(fosinfo);
   regs.di := Ofs(fosinfo);
   regs.dx := PortNum;
   intr($14,regs);
   p := ptr(fosinfo.offset,fosinfo.segment);
   s := Asc2Str(p^ , 255);
   FossilIdStr := s;
end;


procedure modemput( initstr : String); { send a command to modem }
var i: integer;
begin
  for i := 1 to length(initstr) do begin
    case initstr[i] of
      '-' : begin end;      { Hyphen        Stripped            }
      '.' : send(',');      { Period        Translated to Comma }
      '^' : setdtr(TRUE);   { Carat         Raise DTR Line      }
      '`' : delay(50);      { Accent Mark   1/20th Second Delay }
      'v' : setdtr(FALSE);  { Lower Case V  Lower DTR Line      }
      '|' : send(#13);       { Pipe,Bar      Carriage Return Sent}
      '~' : delay(1000);    { Tilde         1 Second Delay      }
    else Send(initstr[i]);
    end; { case }
    delay(10);
  end; { for }
  {FlushBuff;}
  Delay(500);
end;


function readline(seconds:integer): integer;
var j : integer;
begin
    j := loopspersec * seconds;
    repeat
      dec(j)
    until SerialChar OR (j = 0);
    IF j = 0 THEN
       READLINE := timeout
    ELSE READLINE := ORD(Receive);
end;


procedure purgeline; assembler;
asm
    mov ah, 0aH
    mov dx, Portnum
    Int 14H
end;


procedure purgeoutput; assembler;
asm
   mov ah, 9
   mov dx, PortNum
   int 14H
end;


procedure setcheck( on : boolean); assembler;
asm
    mov ah,  10H
    mov dx,  Portnum
    mov al,  on
    int 14H
end;


procedure sendtext(initstr: string);
var i: integer;
begin
   for i := 1 to ord(initstr[0]) DO send(initstr[i]);
end;


procedure hangupphone;
var i : integer;
    regs : Registers;
begin
  setdtr(false);
  delay(1000);
  repeat
     delay(500);
     inc(i);
  until (not carrier) OR (i >= 5);
  if carrier then write(#07+#07+#07+#07,'*Hangup Manually*');
  setdtr(true);
end;


PROCEDURE SendBlk(Seg_Ment, Off_Set, count : word);
begin
(*
   regs.es := seg_ment;
   while (count > 0) do
   begin
      regs.ah := $19;
      regs.di := off_set;
      regs.cx := count;
      regs.dx := PortNum;
      intr($14,regs);
      count := count - regs.ax;
      off_set := off_set + regs.ax;
   end;
*)
asm
      mov ES, Seg_Ment
 @1:  mov CX, Count
      mov AH, 19H
      mov DI, Off_Set
      mov DX, PortNum
      int 14H
      sub Count, AX
      add Off_Set, AX
      cmp Count, 0
      jnz @1
end;
end;


PROCEDURE ReadBlk(segment,offset,count : word );
begin
   regs.es := segment;
   while (count > 0) do begin
      regs.ah := $18;
      regs.di := offset;
      regs.cx := count;
      regs.dx := PortNum;
      intr($14,regs);
      count := count - regs.ax;            { # of chars to go }
      offset := offset + regs.ax;
   end;
end;

end.