home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
pascal
/
prot100.zip
/
FOS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-15
|
13KB
|
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.