|
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 - metrics - downloadIndex: T
Length: 28544 (0x6f80)
Types: TextFile
Names: »TRANSPORT_BODY«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
with System;
with Text_Io;
with Vms;
package body Transport is
Debug_On : constant Boolean := False;
Buffer_Size : constant := 1024;
subtype Status_Code is Transport_Defs.Status_Code;
Ok : constant Status_Code := Transport_Defs.Ok;
subtype Host_Address is Transport_Defs.Host_Id (1 .. 4);
subtype Port_Address is Transport_Defs.Socket_Id (1 .. 2);
Null_Socket_Id : constant Transport_Defs.Socket_Id :=
Transport_Defs.Null_Socket_Id;
function "=" (L, R : Transport_Defs.Socket_Id) return Boolean
renames Transport_Defs."=";
function "<" (L, R : Transport_Defs.Socket_Id) return Boolean
renames Transport_Defs."<";
function "<" (L, R : Byte_Defs.Byte) return Boolean renames Byte_Defs."<";
function "+" (L, R : Byte_Defs.Byte) return Byte_Defs.Byte
renames Byte_Defs."+";
First_Internal_Socket : constant Port_Address := (5, 0);
Last_Internal_Socket : constant Port_Address := (99, 255);
--
So_Acceptconn : constant := 2;
So_Socket : constant := 50;
So_Accept : constant := 51;
So_Connect : constant := 52;
So_Close : constant := 56;
--
subtype Function_Code is Vms.Function_Code_Type;
function "+" (L, R : Function_Code) return Function_Code renames Vms."+";
function "*" (L, R : Function_Code) return Function_Code renames Vms."*";
Mult : constant Function_Code := 256;
Io_Access : constant Function_Code := Vms.Io_Access;
Ex_Accept : constant Function_Code := Io_Access + (Mult * So_Accept);
Ex_Close : constant Function_Code := Io_Access + (Mult * So_Close);
Ex_Connect : constant Function_Code := Io_Access + (Mult * So_Connect);
Ex_Read : constant Function_Code := Vms.Io_Endru1;
Ex_Socket : constant Function_Code := Io_Access + (Mult * So_Socket);
Ex_Write : constant Function_Code := Vms.Io_Endru2;
--
type Exos_Status is new System.Unsigned_Byte;
Exos_Ok : constant Exos_Status := 0;
Exos_Eio : constant Exos_Status := 5;
--
type Socket_Address_Type is
record
Internet_Family : System.Unsigned_Word := 2;
Port_Number : Port_Address;
Internet_Address : Host_Address;
Must_Be_Zero : Byte_Defs.Byte_String (1 .. 8) := (others => 0);
end record;
type So_Ioctl_Type is
record
Address_Flag : System.Unsigned_Word;
Socket_Address : Socket_Address_Type;
Protocol_Flag : System.Unsigned_Word := 0;
Socket_Protocol : System.Unsigned_Longword := 0;
Socket_Type : System.Unsigned_Longword := 1; -- Stream
Options : System.Unsigned_Longword;
end record;
--
Device_Name : constant String := "EX";
Tcp_Ip_Name : constant Transport_Defs.Network_Name := "TCP/IP";
Local_Host_Id : Host_Address;
type Connection_State is (Closed, Pre_Connection, Connecting_Active,
Connecting_Passive, Connected);
type Input_Buffer is
record
Data : Byte_Defs.Byte_String (1 .. Buffer_Size);
Cursor : Positive := 1;
Limit : Natural;
end record;
type Connection_Type is
record
State : Connection_State;
Channel : Vms.Channel_Type;
Remote_Host : Host_Address;
Remote_Socket : Port_Address;
Local_Socket : Port_Address;
Read_Buffer : Input_Buffer;
Link : Connection_Id;
end record;
task Connection_Manager is
entry Get_First (First : out Connection_Id);
entry Allocate (Connection : out Connection_Id;
Status : out Status_Code);
entry Deallocate (Connection : Connection_Id);
entry Test_Uniqueness (Socket : Port_Address; Is_Unique : out Boolean);
end Connection_Manager;
task Socket_Manager is
entry Get (Input : Transport_Defs.Socket_Id;
Socket : out Port_Address;
Status : out Status_Code);
--entry Put (Socket : Port_Address);
end Socket_Manager;
function Success (Status : Status_Code) return Boolean is
begin
return Transport_Defs."=" (Status, Ok);
end Success;
function Success (Status : Exos_Status) return Boolean is
begin
return Status = Exos_Ok;
end Success;
function Decode (Status : Exos_Status) return Status_Code is
begin
return Transport_Defs.Access_Denied; -- **
end Decode;
--
procedure Trace (Message : String) is
begin
if Debug_On then
Text_Io.Put_Line (Message);
end if;
end Trace;
procedure Trace (Message : String; Errstat : Exos_Status) is
begin
if Debug_On then
Text_Io.Put_Line (Message & " -- errstat was " &
Exos_Status'Image (Errstat));
end if;
end Trace;
procedure Trace (Message : String; Cc : Vms.Cond_Value_Type) is
begin
if Debug_On then
Text_Io.Put_Line (Message & " -- cc was " & Vms.Image (Cc));
end if;
end Trace;
procedure Trace (Message : String;
Cc : Vms.Cond_Value_Type;
Iosb : Vms.Iosb_Type) is
begin
if Debug_On then
Text_Io.Put_Line (Message & " -- cc was " & Vms.Image (Cc) &
", iosb was " & Vms.Image (Iosb));
end if;
end Trace;
procedure Put_Socket_Id (Socket : Transport_Defs.Socket_Id) is
begin
Text_Io.Put ("(");
for I in Socket'Range loop
Text_Io.Put (Byte_Defs.Byte'Image (Socket (I)));
if I < Socket'Last then
Text_Io.Put (", ");
end if;
end loop;
Text_Io.Put (")");
end Put_Socket_Id;
procedure Put_Host_Id (Host : Transport_Defs.Host_Id) is
begin
Text_Io.Put ("(");
for I in Host'Range loop
Text_Io.Put (Byte_Defs.Byte'Image (Host (I)));
if I < Host'Last then
Text_Io.Put (", ");
end if;
end loop;
Text_Io.Put (")");
end Put_Host_Id;
procedure Trace (Message : String; Socket : Transport_Defs.Socket_Id) is
begin
if Debug_On then
Text_Io.Put (Message & " -- ");
Put_Socket_Id (Socket);
Text_Io.New_Line;
end if;
end Trace;
procedure Trace (Message : String;
Host : Transport_Defs.Host_Id;
Socket : Transport_Defs.Socket_Id) is
begin
if Debug_On then
Text_Io.Put (Message & " -- host: ");
Put_Host_Id (Host);
Text_Io.Put ("; socket: ");
Put_Socket_Id (Socket);
Text_Io.New_Line;
end if;
end Trace;
--
procedure Unimplemented (Message : String) is
begin
Text_Io.Put_Line ("Unimplemented: " & Message);
raise Program_Error;
end Unimplemented;
--
task body Connection_Manager is
Used_List : Connection_Id;
Free_List : Connection_Id;
Work : Connection_Id;
begin
loop
select
accept Get_First (First : out Connection_Id) do
First := Used_List;
end Get_First;
or
accept Allocate (Connection : out Connection_Id;
Status : out Status_Code) do
Trace ("Connection_Manager.Allocate");
if Free_List /= null then
Work := Free_List;
Free_List := Work.Link;
else
Work := new Connection_Type;
Work.State := Closed;
end if;
Work.Link := Used_List;
Used_List := Work;
Connection := Work;
Status := Ok;
end Allocate;
or
accept Deallocate (Connection : Connection_Id) do
Trace ("Connection_Manager.Deallocate");
if Used_List = Connection then
Used_List := Connection.Link;
else
Work := Used_List;
loop
if Work.Link = Connection then
Work.Link := Connection.Link;
exit;
end if;
Work := Work.Link;
end loop;
end if;
Connection.Link := Free_List;
Free_List := Connection;
end Deallocate;
or
accept Test_Uniqueness (Socket : Port_Address;
Is_Unique : out Boolean) do
Trace ("Connection_Manager.Test_Uniqueness", Socket);
Work := Used_List;
while Work /= null loop
if Work.State /= Closed and then
Socket = Work.Local_Socket then
Is_Unique := False;
return;
end if;
Work := Work.Link;
end loop;
Is_Unique := True;
end Test_Uniqueness;
end select;
end loop;
end Connection_Manager;
--
function Normalize (Socket : Transport_Defs.Socket_Id)
return Port_Address is
begin
case Socket'Length is
when 1 =>
return Port_Address'(1 => 0, 2 => Socket (Socket'First));
when 2 =>
return Port_Address (Socket);
when others =>
return Port_Address (Socket (Socket'Last - 1 .. Socket'Last));
end case;
end Normalize;
task body Socket_Manager is
Internal_Socket : Port_Address := First_Internal_Socket;
procedure Bump_Internal_Socket (Wraps : in out Natural) is
begin
if Internal_Socket < Last_Internal_Socket then
if Internal_Socket (2) < 255 then
Internal_Socket (2) := Internal_Socket (2) + 1;
else
Internal_Socket (2) := 0;
Internal_Socket (1) := Internal_Socket (1) + 1;
end if;
else
Internal_Socket := First_Internal_Socket;
Wraps := Wraps + 1;
end if;
end Bump_Internal_Socket;
procedure Generate_Unique_Socket
(Socket : out Port_Address; Status : out Status_Code) is
Wraps : Natural := 0;
Is_Unique : Boolean;
begin
loop
Socket := Internal_Socket;
Connection_Manager.Test_Uniqueness (Internal_Socket, Is_Unique);
Bump_Internal_Socket (Wraps);
if Is_Unique then
Status := Ok;
return;
elsif Wraps > 1 then
Status := Transport_Defs.No_Free_Sockets;
return;
end if;
end loop;
end Generate_Unique_Socket;
begin
loop
accept Get (Input : Transport_Defs.Socket_Id;
Socket : out Port_Address;
Status : out Status_Code) do
Trace ("Socket_Manager.Get", Input);
if Input = Null_Socket_Id then
Generate_Unique_Socket (Socket, Status);
else
Socket := Normalize (Input);
Status := Ok;
end if;
end Get;
end loop;
end Socket_Manager;
--
procedure Assign_Channel (Channel : out Vms.Channel_Type;
Status : out Status_Code) is
Cc : Vms.Cond_Value_Type;
begin
Trace ("Assign_Channel");
Vms.Assign (Status => Cc, Devnam => Device_Name, Chan => Channel);
if Vms.Success (Cc) then
Status := Ok;
Trace ("Assign_Channel: Ok");
else
Status := Transport_Defs.No_Local_Resources;
Trace ("Assign_Channel", Cc);
end if;
end Assign_Channel;
procedure Deassign_Channel (Channel : in Vms.Channel_Type) is
Cc : Vms.Cond_Value_Type;
begin
Trace ("Deassign_Channel");
Vms.Dassgn (Status => Cc, Chan => Channel);
Trace ("Deassign_Channel", Cc);
end Deassign_Channel;
function Extract_Reply (Iosb : Vms.Iosb_Type) return Exos_Status is
begin
return Exos_Status (System."/" (Iosb.Dev_Info, 256));
end Extract_Reply;
procedure Ex_Control (Func : Vms.Function_Code_Type;
Channel : Vms.Channel_Type;
So_Ioctl_Address : System.Address;
Status : out Exos_Status) is
Cc : Vms.Cond_Value_Type;
Iosb : Vms.Iosb_Type;
begin
Trace ("Ex_Control: function " & Vms.Function_Code_Type'Image (Func));
Vms.Qiow (Status => Cc,
Chan => Channel,
Func => Func,
Iosb => Iosb'Address,
P3 => Vms.To_Unsigned_Longword (So_Ioctl_Address));
Trace ("Ex_Control", Cc, Iosb);
if Vms.Success (Cc) then
Status := Extract_Reply (Iosb);
else
Status := Exos_Eio;
end if;
end Ex_Control;
procedure Ex_Io (Func : Vms.Function_Code_Type;
Channel : Vms.Channel_Type;
Buffer_Address : System.Address;
Length : in out Natural;
Status : out Exos_Status) is
Cc : Vms.Cond_Value_Type;
Iosb : Vms.Iosb_Type;
begin
Trace ("Ex_Io: function " & Vms.Function_Code_Type'Image (Func));
Vms.Qiow (Status => Cc,
Chan => Channel,
Func => Func,
Iosb => Iosb'Address,
P1 => Vms.To_Unsigned_Longword (Buffer_Address),
P2 => System.Unsigned_Longword (Length));
Trace ("Ex_Io", Cc, Iosb);
if Vms.Success (Cc) then
Length := Natural (Iosb.Count);
Status := Extract_Reply (Iosb);
else
Status := Exos_Eio;
end if;
end Ex_Io;
procedure Open (Connection : out Transport.Connection_Id;
Status : out Transport_Defs.Status_Code;
Network : Transport_Defs.Network_Name;
Local_Socket : Transport_Defs.Socket_Id :=
Transport_Defs.Null_Socket_Id) is
Conn : Connection_Id;
Stat : Transport_Defs.Status_Code;
begin
Trace ("Open");
if Transport_Defs."/=" (Network, Tcp_Ip_Name) then
Status := Transport_Defs.No_Such_Network;
return;
end if;
Connection_Manager.Allocate (Conn, Stat);
if Success (Stat) then
Socket_Manager.Get (Local_Socket, Conn.Local_Socket, Stat);
end if;
if Success (Stat) then
Assign_Channel (Conn.Channel, Stat);
end if;
if Success (Stat) then
Conn.State := Pre_Connection;
Connection := Conn;
else
Connection_Manager.Deallocate (Conn);
end if;
Status := Stat;
end Open;
procedure Close (Connection : Transport.Connection_Id) is
begin
if Connection.State = Connected then
Disconnect (Connection);
end if;
if Connection.State /= Closed then
Deassign_Channel (Connection.Channel);
Connection.State := Closed;
Connection_Manager.Deallocate (Connection);
end if;
end Close;
generic
Connecting_State : Connection_State;
Connect_Command : Vms.Function_Code_Type;
Socket_Options : System.Unsigned_Longword;
with procedure Set_Socket_Address
(Socket_Addr : in out Socket_Address_Type);
procedure Generic_Connect (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code);
procedure Generic_Connect (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code) is
So_Ioctl : So_Ioctl_Type;
Socket_Addr : Socket_Address_Type renames So_Ioctl.Socket_Address;
Errstat : Exos_Status;
begin
if not Is_Open (Connection) then
Status := Transport_Defs.Not_Open;
return;
end if;
So_Ioctl.Address_Flag := 1;
Socket_Addr.Internet_Address := Local_Host_Id;
Socket_Addr.Port_Number := Connection.Local_Socket;
So_Ioctl.Options := Socket_Options;
Ex_Control (Func => Ex_Socket,
Channel => Connection.Channel,
So_Ioctl_Address => So_Ioctl'Address,
Status => Errstat);
if Success (Errstat) then
Set_Socket_Address (Socket_Addr);
Connection.State := Connecting_State;
Ex_Control (Func => Connect_Command,
Channel => Connection.Channel,
So_Ioctl_Address => So_Ioctl'Address,
Status => Errstat);
end if;
if Success (Errstat) then
Trace ("Connect", Socket_Addr.Internet_Address,
Socket_Addr.Port_Number);
Connection.Remote_Host := Socket_Addr.Internet_Address;
Connection.Remote_Socket := Socket_Addr.Port_Number;
Connection.Read_Buffer.Limit := Connection.Read_Buffer.Cursor;
Connection.State := Connected;
Status := Ok;
else
Connection.State := Pre_Connection;
Status := Decode (Errstat);
end if;
end Generic_Connect;
procedure Connect (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code;
Remote_Host : Transport_Defs.Host_Id;
Remote_Socket : Transport_Defs.Socket_Id;
Max_Wait : Duration := Duration'Last) is
procedure Set_Socket_Address
(Socket_Addr : in out Socket_Address_Type) is
begin
Socket_Addr.Internet_Address := Remote_Host;
Socket_Addr.Port_Number := Remote_Socket;
end Set_Socket_Address;
procedure Active_Connect is
new Generic_Connect (Connecting_State => Connecting_Active,
Connect_Command => Ex_Connect,
Socket_Options => 0,
Set_Socket_Address => Set_Socket_Address);
begin
Active_Connect (Connection, Status);
end Connect;
procedure Connect (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code;
Max_Wait : Duration := Duration'Last) is
procedure No_Op (Socket_Addr : in out Socket_Address_Type) is
begin
-- the socket address is an "out parameter" of the Ex_Accept
null;
end No_Op;
procedure Passive_Connect is
new Generic_Connect (Connecting_State => Connecting_Passive,
Connect_Command => Ex_Accept,
Socket_Options => So_Acceptconn,
Set_Socket_Address => No_Op);
begin
Passive_Connect (Connection, Status);
end Connect;
procedure Disconnect (Connection : Transport.Connection_Id) is
begin
Trace ("Disconnect");
if Connection.State = Connected then
Connection.State := Pre_Connection;
null; -- ** for now, don't close the socket
end if;
end Disconnect;
procedure Copy_Data (Src : in Byte_Defs.Byte_String;
Dst : out Byte_Defs.Byte_String;
Count : out Natural) is
begin
case Integer'(Src'Length) - Integer'(Dst'Length) is
when 0 =>
Dst := Src;
Count := Dst'Length;
when Positive =>
Dst := Src (Src'First .. Src'First + Dst'Length - 1);
Count := Dst'Length;
when others =>
Dst (Dst'First .. Dst'First + Src'Length - 1) := Src;
Count := Src'Length;
end case;
end Copy_Data;
procedure Transmit (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code;
Data : Byte_Defs.Byte_String;
Count : out Natural;
Max_Wait : Duration := Duration'Last;
More : Boolean := False) is
Length : Natural := Data'Length;
Errstat : Exos_Status;
begin
case Connection.State is
when Connected =>
Ex_Io (Func => Ex_Write,
Channel => Connection.Channel,
Buffer_Address => Data'Address,
Length => Length,
Status => Errstat);
Trace ("Transmit", Errstat);
if Success (Errstat) then
Count := Length;
Status := Ok;
else
Status := Transport_Defs.Disconnected;
end if;
when Closed =>
Count := 0;
Status := Transport_Defs.Not_Open;
when others =>
Count := 0;
Status := Transport_Defs.Not_Connected;
end case;
end Transmit;
procedure Receive_Data (Connection : Connection_Id;
Status : out Status_Code;
Data : out Byte_Defs.Byte_String;
Count : out Natural) is
Buffer : Input_Buffer renames Connection.Read_Buffer;
Length : Natural;
Errstat : Exos_Status;
begin
if Buffer.Cursor = Buffer.Limit then
Buffer.Cursor := Buffer.Data'First;
Length := Buffer.Data'Length;
Ex_Io (Func => Ex_Read,
Channel => Connection.Channel,
Buffer_Address => Buffer.Data'Address,
Length => Length,
Status => Errstat);
Trace ("Receive_Data", Errstat);
if Success (Errstat) then
Buffer.Limit := Buffer.Cursor + Length;
if Length = 0 then
Count := 0;
Status := Transport_Defs.Disconnected;
return;
end if;
else
Buffer.Limit := Buffer.Cursor - 1;
end if;
end if;
if Buffer.Cursor < Buffer.Limit then
Copy_Data (Src => Buffer.Data (Buffer.Cursor .. Buffer.Limit - 1),
Dst => Data,
Count => Length);
Buffer.Cursor := Buffer.Cursor + Length;
Count := Length;
Status := Ok;
Trace ("Receive_Data: length " & Integer'Image (Length) &
", cursor " & Integer'Image (Buffer.Cursor));
else
Count := 0;
Status := Transport_Defs.Connection_Broken;
end if;
end Receive_Data;
procedure Receive (Connection : Transport.Connection_Id;
Status : out Transport_Defs.Status_Code;
Data : out Byte_Defs.Byte_String;
Count : out Natural;
Max_Wait : Duration := Duration'Last) is
begin
case Connection.State is
when Connected =>
Receive_Data (Connection, Status, Data, Count);
when Closed =>
Count := 0;
Status := Transport_Defs.Not_Open;
when others =>
Count := 0;
Status := Transport_Defs.Not_Connected;
end case;
end Receive;
-------------------------------------------------------------------
-------- Predicates and Assorted Info -----------------------------
-------------------------------------------------------------------
function Is_Open (Connection : Transport.Connection_Id) return Boolean is
begin
return Connection.State /= Closed;
end Is_Open;
function Is_Connecting_Passive
(Connection : Transport.Connection_Id) return Boolean is
begin
return Connection.State = Connecting_Passive;
end Is_Connecting_Passive;
function Is_Connecting_Active
(Connection : Transport.Connection_Id) return Boolean is
begin
return Connection.State = Connecting_Active;
end Is_Connecting_Active;
function Is_Connected
(Connection : Transport.Connection_Id) return Boolean is
begin
return Connection.State = Connected;
end Is_Connected;
function Hash (Connection : Transport.Connection_Id) return Natural is
begin
return 0; -- ** for now
end Hash;
function Network (Connection : Transport.Connection_Id)
return Transport_Defs.Network_Name is
begin
return Tcp_Ip_Name;
end Network;
procedure Initialize_Local_Host is
begin
Local_Host_Id := (0, 0, 0, 0);
end Initialize_Local_Host;
function Local_Host (Network : Transport_Defs.Network_Name)
return Transport_Defs.Host_Id is
begin
return Local_Host_Id;
end Local_Host;
function Local_Host (Connection : Transport.Connection_Id)
return Transport_Defs.Host_Id is
begin
return Local_Host_Id;
end Local_Host;
function Local_Socket (Connection : Transport.Connection_Id)
return Transport_Defs.Socket_Id is
begin
return Connection.Local_Socket;
end Local_Socket;
function Remote_Host (Connection : Transport.Connection_Id)
return Transport_Defs.Host_Id is
begin
return Connection.Remote_Host;
end Remote_Host;
function Remote_Socket (Connection : Transport.Connection_Id)
return Transport_Defs.Socket_Id is
begin
return Connection.Remote_Socket;
end Remote_Socket;
-------------------------------------------------------------------
-------- Network_Name_Iterator ------------------------------------
-------------------------------------------------------------------
procedure Init (Iter : in out Network_Name_Iterator) is
begin
Iter := 0;
end Init;
procedure Next (Iter : in out Network_Name_Iterator) is
begin
Iter := Iter + 1;
end Next;
function Done (Iter : Network_Name_Iterator) return Boolean is
begin
return Iter > 0;
end Done;
function Value (Iter : Network_Name_Iterator)
return Transport_Defs.Network_Name is
begin
if Done (Iter) then
raise Constraint_Error;
else
return Tcp_Ip_Name;
end if;
end Value;
-------------------------------------------------------------------
-------- Connection_Id_Iterator -----------------------------------
-------------------------------------------------------------------
procedure Init (Iter : in out Connection_Id_Iterator) is
begin
Connection_Manager.Get_First (Connection_Id (Iter));
end Init;
procedure Next (Iter : in out Connection_Id_Iterator) is
begin
Iter := Connection_Id_Iterator (Iter.Link);
end Next;
function Done (Iter : Connection_Id_Iterator) return Boolean is
begin
return Iter = null;
end Done;
function Value (Iter : Connection_Id_Iterator) return Connection_Id is
begin
if Done (Iter) then
raise Constraint_Error;
else
return Connection_Id (Iter);
end if;
end Value;
begin
Initialize_Local_Host;
end Transport;