|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 27594 (0x6bca)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─ ⟦d65440be7⟧ »DATA«
└─⟦this⟧
with System;
with Unchecked_Conversion;
with Mac_Types;
use Mac_Types;
with Memory;
with Osutils;
with Devices;
package body Tcp is
-- MacTCP return Codes in the range -23000 through -23049
Inprogress : constant := 1; -- I/O in progress
Ipbadlaperr : constant := -23000; -- bad network configuration
Ipbadcnfgerr : constant := -23001; -- bad IP configuration error
Ipnocnfgerr : constant := -23002; -- missing IP or LAP configuration error
Iploaderr : constant := -23003; -- error in MacTCP load
Ipbadaddr : constant := -23004; -- error in getting address
Connectionclosing : constant := -23005; -- connection is closing
Invalidlength : constant := -23006;
Connectionexists : constant :=
-23007; -- request conflicts with existing connection
Connectiondoesntexist : constant := -23008; -- connection does not exist
Insufficientresources : constant :=
-23009; -- insufficient resources to perform request
Invalidstreamptr : constant := -23010;
Streamalreadyopen : constant := -23011;
Connectionterminated : constant := -23012;
Invalidbufptr : constant := -23013;
Invalidrds : constant := -23014;
Invalidwds : constant := -23014;
Openfailed : constant := -23015;
Commandtimeout : constant := -23016;
Duplicatesocket : constant := -23017;
-- Error codes from internal IP functions
Ipdontfragerr : constant :=
-23032; -- Packet too large to send w/o fragmenting
Ipdestdeaderr : constant := -23033; -- destination not responding
Ipnofragmemerr : constant := -23036; -- no memory to send fragmented pkt
Iprouteerr : constant := -23037; -- can't route packet off-net
Namesyntaxerr : constant := -23041;
Cachefault : constant := -23042;
Noresultproc : constant := -23043;
Nonameserver : constant := -23044;
Authnameerr : constant := -23045;
Noanserr : constant := -23046;
Dnrerr : constant := -23047;
Outofmemory : constant := -23048;
-- Command codes
Ipctlgetaddr : constant := 15;
Tcpcreate : constant := 30;
Tcppassiveopen : constant := 31;
Tcpactiveopen : constant := 32;
Tcpsend : constant := 34;
Tcpnocopyrcv : constant := 35;
Tcprcvbfrreturn : constant := 36;
Tcprcv : constant := 37;
Tcpclose : constant := 38;
Tcpabort : constant := 39;
Tcpstatus : constant := 40;
Tcpextendedstat : constant := 41;
Tcprelease : constant := 42;
Tcpglobalinfo : constant := 43;
Tcpctlmax : constant := 49;
type Ippb is
record
Fill1 : Mac_Types.Longint;
Fill2 : Mac_Types.Longint;
Fill3 : Mac_Types.Longint;
Iocompletion : Mac_Types.Procptr;
Ioresult : Mac_Types.Integer;
Ionameptr : Mac_Types.Stringptr;
Iovrefnum : Mac_Types.Integer;
Iocrefnum : Mac_Types.Integer;
Cscode : Mac_Types.Integer;
Ouraddress : Ip_Addr;
Ournetmask : Mac_Types.Longint;
end record;
type Ippbptr is access Ippb;
type Tcpcreatepb is
record
Fill1 : Mac_Types.Longint;
Fill2 : Mac_Types.Longint;
Fill3 : Mac_Types.Longint;
Iocompletion : Mac_Types.Procptr; -- TCPIOCompletionProc;
Ioresult : Mac_Types.Integer;
Ionameptr : Mac_Types.Stringptr;
Iovrefnum : Mac_Types.Integer;
Iocrefnum : Mac_Types.Integer;
Cscode : Mac_Types.Integer;
Tcpstream : Stream_Ptr;
Rcvbuff : Mac_Types.Ptr;
Rcvbufflen : Mac_Types.Longint;
Notifyproc : Mac_Types.Procptr; -- TCPNotifyProc
Userdataptr : Mac_Types.Ptr;
end record;
type Tcpcreatepbptr is access Tcpcreatepb;
type Tcpclosepb is
record
Fill1 : Mac_Types.Longint;
Fill2 : Mac_Types.Longint;
Fill3 : Mac_Types.Longint;
Iocompletion : Mac_Types.Procptr; -- TCPIOCompletionProc;
Ioresult : Mac_Types.Integer;
Ionameptr : Mac_Types.Stringptr;
Iovrefnum : Mac_Types.Integer;
Iocrefnum : Mac_Types.Integer;
Cscode : Mac_Types.Integer;
Tcpstream : Stream_Ptr;
Ulptimeoutvalue : Mac_Types.Byte;
Ulptimeoutaction : Mac_Types.Byte;
Validityflags : Mac_Types.Byte;
Userdataptr : Mac_Types.Ptr;
end record;
type Tcpclosepbptr is access Tcpclosepb;
type Tcpabortpb is
record
Fill1 : Mac_Types.Longint;
Fill2 : Mac_Types.Longint;
Fill3 : Mac_Types.Longint;
Iocompletion : Mac_Types.Procptr; -- TCPIOCompletionProc;
Ioresult : Mac_Types.Integer;
Ionameptr : Mac_Types.Stringptr;
Iovrefnum : Mac_Types.Integer;
Iocrefnum : Mac_Types.Integer;
Cscode : Mac_Types.Integer;
Tcpstream : Stream_Ptr;
Userdataptr : Mac_Types.Ptr;
end record;
type Tcpabortpbptr is access Tcpabortpb;
type Tcpglobalinfopb is
record
Fill1 : Mac_Types.Longint;
Fill2 : Mac_Types.Longint;
Fill3 : Mac_Types.Longint;
Iocompletion : Mac_Types.Procptr; -- TCPIOCompletionProc;
Ioresult : Mac_Types.Integer;
Ionameptr : Mac_Types.Stringptr;
Iovrefnum : Mac_Types.Integer;
Iocrefnum : Mac_Types.Integer;
Cscode : Mac_Types.Integer;
Tcpstream : Stream_Ptr;
Tcpparamptr : Tcp.Tcpparamptr;
Tcpstatsptr : Tcp.Tcpstatsptr;
Tcpcdbtable : Mac_Types.Varlongint;
Userdataptr : Mac_Types.Ptr;
end record;
type Tcpglobalinfopbptr is access Tcpglobalinfopb;
Csleeptime : constant := 0.3;
Refnum : Mac_Types.Integer := 0;
-- Conversion
function As_Varinteger is new Unchecked_Conversion
(Source => System.Address,
Target => Mac_Types.Varinteger);
function As_Ippbptr is new Unchecked_Conversion
(Source => Ptr, Target => Ippbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Ippbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Source => Ippbptr,
Target => Osutils.Parmblkptr);
function As_Tcpcreatepbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpcreatepbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpcreatepbptr, Target => Ptr);
function As_Parmblkptr is new Unchecked_Conversion
(Source => Tcpcreatepbptr,
Target => Osutils.Parmblkptr);
function As_Tcpopenpbptr is new Unchecked_Conversion
(Source => Ptr, Target => Tcpopenpbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpopenpbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Source => Tcpopenpbptr,
Target => Osutils.Parmblkptr);
function As_Tcpsendpbptr is new Unchecked_Conversion
(Source => Ptr, Target => Tcpsendpbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpsendpbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Source => Tcpsendpbptr,
Target => Osutils.Parmblkptr);
function As_Tcpreceivepbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpreceivepbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpreceivepbptr, Target => Ptr);
function As_Parmblkptr is new Unchecked_Conversion
(Source => Tcpreceivepbptr,
Target => Osutils.Parmblkptr);
function As_Tcpclosepbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpclosepbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpclosepbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Source => Tcpclosepbptr,
Target => Osutils.Parmblkptr);
function As_Tcpabortpbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpabortpbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpabortpbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Source => Tcpabortpbptr,
Target => Osutils.Parmblkptr);
function As_Tcpstatuspbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpstatuspbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpstatuspbptr, Target => Ptr);
function As_Parmblkptr is new Unchecked_Conversion
(Source => Tcpstatuspbptr,
Target => Osutils.Parmblkptr);
function As_Tcpglobalinfopbptr is
new Unchecked_Conversion (Source => Ptr, Target => Tcpglobalinfopbptr);
function As_Ptr is new Unchecked_Conversion
(Source => Tcpglobalinfopbptr, Target => Ptr);
function As_Parmblkptr is
new Unchecked_Conversion (Tcpglobalinfopbptr,
Target => Osutils.Parmblkptr);
-- Raise an exception if an error occured
procedure Check_Error (Err : Mac_Types.Oserr) is
begin
case Err is
when Mac_Types.Noerr =>
null;
when Commandtimeout =>
raise Timeout_Error;
when others =>
raise Device_Error;
end case;
end Check_Error;
-- Opens the MacTCP driver.
use Mac_Types;
procedure Open_Tcp_Driver is
Err : Oserr;
Ipp_Name : Str255;
begin
Ipp_Name (0) := Char'Val (4);
Ipp_Name (1 .. 4) := ".IPP";
Err := Devices.Opendriver (Ipp_Name, As_Varinteger (Refnum'Address));
Check_Error (Err);
end Open_Tcp_Driver;
-- Creates a new TCP stream in preparation for initiating a connection.
-- A buffer must be provided for storing incoming data waiting to be processed
procedure Low_Tcp_Create_Stream (A_Stream : out Stream_Ptr;
Connectionbuffer : Ptr;
Connbufferlen : Natural;
Notify_Proc : Procptr;
Userdataptr : Ptr) is
Err : Oserr;
Pb : Tcpcreatepbptr;
begin
Pb := As_Tcpcreatepbptr (Memory.Newptr (Tcpcreatepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpcreate;
Pb.Ioresult := 1;
Pb.Rcvbuff := Connectionbuffer;
Pb.Rcvbufflen := Connbufferlen;
Pb.Notifyproc := Notify_Proc;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
A_Stream := Pb.Tcpstream;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Create_Stream;
-- If TCPWaitForConnection is called asynchronously, this command retrieves the
-- result of the call. It should be called when the above command completes.
procedure Low_Finish_Tcp_Wait_For_Connection (Pb : in out Tcpopenpbptr;
Remotehost : out Ip_Addr;
Remoteport : out Tcp_Port;
Localhost : out Ip_Addr;
Localport : out Tcp_Port) is
Err : Oserr;
begin
Remotehost := Pb.Remotehost;
Remoteport := Pb.Remoteport;
Localhost := Pb.Localhost;
Localport := Pb.Localport;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Pb := null;
Check_Error (Err);
end Low_Finish_Tcp_Wait_For_Connection;
-- Waits for a connection to be opened on a specified port from a specified address.
-- It completes when a connection is made, or a timeout value is reached. This call
-- may be made asynchronously.
procedure Low_Tcp_Wait_For_Connection (A_Stream : Stream_Ptr;
Timeout : Byte;
Remotehost : in out Ip_Addr;
Remoteport : in out Tcp_Port;
Localhost : out Ip_Addr;
Localport : in out Tcp_Port;
Async : Boolean;
Userdataptr : Ptr;
Returnblock : out Tcpopenpbptr) is
Err : Oserr;
Pb : Tcpopenpbptr;
begin
Pb := As_Tcpopenpbptr (Memory.Newptr (Tcpopenpb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcppassiveopen;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Ulptimeoutvalue := Timeout;
Pb.Ulptimeoutaction := 1;
Pb.Validityflags := 16#C0#;
Pb.Commandtimeoutvalue := Timeout;
Pb.Remotehost := Remotehost;
Pb.Remoteport := Remoteport;
Pb.Localport := Localport;
Pb.Tosflags := 0;
Pb.Precedence := 0;
Pb.Dontfrag := False;
Pb.Timetolive := 0;
Pb.Security := 0;
Pb.Optioncnt := 0;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
if not Async then
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Low_Finish_Tcp_Wait_For_Connection
(Pb, Remotehost, Remoteport, Localhost, Localport);
end if;
Returnblock := Pb;
end Low_Tcp_Wait_For_Connection;
-- Attempts to initiate a connection with a host specified by host and port.
procedure Low_Tcp_Open_Connection (A_Stream : Stream_Ptr;
Timeout : Byte;
Remotehost : Ip_Addr;
Remoteport : Tcp_Port;
Localhost : out Ip_Addr;
Localport : in out Tcp_Port;
Userdataptr : Ptr) is
Err : Oserr;
Pb : Tcpopenpbptr;
begin
Pb := As_Tcpopenpbptr (Memory.Newptr (Tcpopenpb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpactiveopen;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Ulptimeoutvalue := Timeout;
Pb.Ulptimeoutaction := 1;
Pb.Validityflags := 16#C0#;
Pb.Commandtimeoutvalue := Timeout;
Pb.Remotehost := Remotehost;
Pb.Remoteport := Remoteport;
Pb.Localport := Localport;
Pb.Tosflags := 0;
Pb.Precedence := 0;
Pb.Dontfrag := False;
Pb.Timetolive := 0;
Pb.Security := 0;
Pb.Optioncnt := 0;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Localhost := Pb.Localhost;
Localport := Pb.Localport;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Open_Connection;
-- This routine should be called when a TCPSendData call completes. It returns the
-- error code generated upon completion of the CallTCPSend.
procedure Low_Finish_Tcp_Send (Pb : in out Tcpsendpbptr) is
Err : Oserr;
begin
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Pb := null;
Check_Error (Err);
end Low_Finish_Tcp_Send;
-- Sends data through an open connection stream. Note that the connection must be
-- open before any data is sent. This call may be made asynchronously.
procedure Low_Tcp_Send_Data (A_Stream : Stream_Ptr;
Timeout : Byte;
Push : Boolean;
Urgent : Boolean;
Wdsptr : Ptr;
Async : Boolean;
Userdataptr : Ptr;
Returnblock : out Tcpsendpbptr) is
Err : Oserr;
Pb : Tcpsendpbptr;
begin
Pb := As_Tcpsendpbptr (Memory.Newptr (Tcpsendpb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpsend;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Ulptimeoutvalue := Timeout;
Pb.Ulptimeoutaction := 1;
Pb.Validityflags := 16#C0#;
Pb.Pushflag := Push;
Pb.Urgentflag := Urgent;
Pb.Wdsptr := Wdsptr;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
if not Async then
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Low_Finish_Tcp_Send (Pb);
end if;
Returnblock := Pb;
end Low_Tcp_Send_Data;
--
procedure Low_Finish_Tcp_No_Copy_Rcv (Pb : in out Tcpreceivepbptr;
Urgent : out Boolean;
Mark : out Boolean) is
Err : Oserr;
begin
Urgent := Pb.Urgentflag;
Mark := Pb.Markflag;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Pb := null;
Check_Error (Err);
end Low_Finish_Tcp_No_Copy_Rcv;
--
procedure Low_Tcp_No_Copy_Rcv (A_Stream : Stream_Ptr;
Timeout : Byte;
Urgent : out Boolean;
Mark : out Boolean;
Rdsptr : Ptr;
Numentry : B_16;
Async : Boolean;
Userdataptr : Ptr;
Returnblock : out Tcpreceivepbptr) is
Err : Oserr;
Pb : Tcpreceivepbptr;
begin
Pb := As_Tcpreceivepbptr (Memory.Newptr (Tcpreceivepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpnocopyrcv;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Commandtimeoutvalue := Timeout;
Pb.Rdsptr := Rdsptr;
Pb.Rdslength := Numentry;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
if not Async then
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Low_Finish_Tcp_No_Copy_Rcv (Pb, Urgent, Mark);
end if;
Returnblock := Pb;
end Low_Tcp_No_Copy_Rcv;
--
procedure Low_Tcp_Bfr_Return (A_Stream : Stream_Ptr; Rdsptr : Ptr) is
Err : Oserr;
Pb : Tcpreceivepbptr;
begin
Pb := As_Tcpreceivepbptr (Memory.Newptr (Tcpreceivepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcprcvbfrreturn;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Rdsptr := Rdsptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Pb := null;
Check_Error (Err);
end Low_Tcp_Bfr_Return;
-- If the below is called asynchronously, this routine returns the data that was
-- received from the remote host.
procedure Low_Finish_Tcp_Recv (Pb : in out Tcpreceivepbptr;
Urgent : out Boolean;
Mark : out Boolean;
Rcvlen : out B_16) is
Err : Oserr;
begin
Rcvlen := Pb.Rcvbufflen;
Urgent := Pb.Urgentflag;
Mark := Pb.Markflag;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Finish_Tcp_Recv;
-- Attempts to pull data out of the incoming stream for a connection. If data is
-- not present, the routine waits a specified amout of time before returning with
-- a timeout error. This call may be made asynchronously.
procedure Low_Tcp_Recv_Data (A_Stream : Stream_Ptr;
Timeout : Byte;
Urgent : out Boolean;
Mark : out Boolean;
Rcvbuff : Ptr;
Rcvlen : in out B_16;
Async : Boolean;
Userdataptr : Ptr;
Returnblock : out Tcpreceivepbptr) is
Err : Oserr;
Pb : Tcpreceivepbptr;
begin
Pb := As_Tcpreceivepbptr (Memory.Newptr (Tcpreceivepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcprcv;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Commandtimeoutvalue := Timeout;
Pb.Rcvbuff := Rcvbuff;
Pb.Rcvbufflen := Rcvlen;
Pb.Userdataptr := Userdataptr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
if not Async then
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Low_Finish_Tcp_Recv (Pb, Urgent, Mark, Rcvlen);
end if;
Returnblock := Pb;
end Low_Tcp_Recv_Data;
-- Gracefully closes a connection with a remote host. This is not always possible,
-- and the programmer might have to resort to CallTCPAbort, described next.
procedure Low_Tcp_Close (A_Stream : Stream_Ptr; Timeout : Byte) is
Err : Oserr;
Pb : Tcpclosepbptr;
begin
Pb := As_Tcpclosepbptr (Memory.Newptr (Tcpclosepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpclose;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Ulptimeoutvalue := Timeout;
Pb.Validityflags := 16#C0#;
Pb.Ulptimeoutaction := 1;
Pb.Userdataptr := null;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Close;
-- Should be called if a CallTCPClose fails to close a connection properly.
-- This call should not normally be used to terminate connections.
procedure Low_Tcp_Abort (A_Stream : Stream_Ptr) is
Err : Oserr;
Pb : Tcpabortpbptr;
begin
Pb := As_Tcpabortpbptr (Memory.Newptr (Tcpabortpb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpabort;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Userdataptr := null;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Abort;
--
procedure Low_Tcp_Status (A_Stream : Stream_Ptr;
Thestatus : out Tcpstatuspb) is
Err : Oserr;
Pb : Tcpstatuspbptr;
begin
Pb := As_Tcpstatuspbptr (Memory.Newptr (Tcpstatuspb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpstatus;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Userdataptr := null;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Thestatus := Pb.all;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Status;
-- Deallocates internal buffers used to hold connection data. This should be
-- called after a connection has been closed.
procedure Low_Tcp_Release (A_Stream : Stream_Ptr;
Recvptr : out Ptr;
Recvlen : out Longint) is
Err : Oserr;
Pb : Tcpcreatepbptr;
begin
Pb := As_Tcpcreatepbptr (Memory.Newptr (Tcpcreatepb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcprelease;
Pb.Ioresult := 1;
Pb.Tcpstream := A_Stream;
Pb.Userdataptr := null;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Recvptr := Pb.Rcvbuff;
Recvlen := Pb.Rcvbufflen;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Release;
--
procedure Low_Tcp_Global_Info
(Tcpparam : out Tcpparamptr; Tcpstat : out Tcpstatsptr) is
Err : Oserr;
Pb : Tcpglobalinfopbptr;
begin
Pb := As_Tcpglobalinfopbptr (Memory.Newptr (Tcpglobalinfopb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Cscode := Tcpglobalinfo;
Pb.Ioresult := 1;
Pb.Userdataptr := null;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Tcpparam := Pb.Tcpparamptr;
Tcpstat := Pb.Tcpstatsptr;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Low_Tcp_Global_Info;
-- Returns the IP address of the local computer.
procedure Get_My_Ip (Ipnum : out Ip_Addr) is
Err : Oserr;
Pb : Ippbptr;
begin
Pb := As_Ippbptr (Memory.Newptr (Ippb'Size / 8));
Pb.Iocompletion := null;
Pb.Iocrefnum := Refnum;
Pb.Ioresult := 1;
Pb.Cscode := Ipctlgetaddr;
Err := Devices.Pbcontrol (As_Parmblkptr (Pb), True);
while Pb.Ioresult = 1 loop
delay Csleeptime;
end loop;
Ipnum := Pb.Ouraddress;
Err := Pb.Ioresult;
Memory.Disposptr (As_Ptr (Pb));
Check_Error (Err);
end Get_My_Ip;
-- Kills any pending calls to the TCP driver
procedure Low_Kill_Tcp (Pb : Tcpopenpbptr) is
begin
Check_Error (Devices.Pbkillio (As_Parmblkptr (Pb), False));
end Low_Kill_Tcp;
procedure Low_Kill_Tcp (Pb : Tcpsendpbptr) is
begin
Check_Error (Devices.Pbkillio (As_Parmblkptr (Pb), False));
end Low_Kill_Tcp;
procedure Low_Kill_Tcp (Pb : Tcpreceivepbptr) is
begin
Check_Error (Devices.Pbkillio (As_Parmblkptr (Pb), False));
end Low_Kill_Tcp;
end Tcp;