|
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: 7914 (0x1eea)
Types: TextFile
Names: »B«
└─⟦5f3412b64⟧ Bits:30000745 8mm tape, Rational 1000, ENVIRONMENT 12_6_5 TOOLS
└─ ⟦91c658230⟧ »DATA«
└─⟦458657fb6⟧
└─⟦a5bbbb819⟧
└─⟦this⟧
└─⟦d10a02448⟧ Bits:30000409 8mm tape, Rational 1000, ENVIRONMENT, D_12_7_3
└─ ⟦fc9b38f02⟧ »DATA«
└─⟦9b46a407a⟧
└─⟦eec0a994f⟧
└─⟦this⟧
with Io_Exceptions;
with Interchange;
with Transport_Interchange;
package body Rpc_Server is
Supported_Versions : constant Rpc.Version_Range := (3, 5);
procedure Begin_Response (Stream : Transport_Stream.Stream_Id;
Id : Rpc.Transaction_Id) is
Response : Rpc.Message_Header (Kind => Rpc.Return_Message) :=
(Rpc.Return_Message, Id);
begin
Rpc.Put_Message (Stream, Response);
end Begin_Response;
procedure Return_Exception (Stream : Transport_Stream.Stream_Id;
Id : Rpc.Transaction_Id;
Excep : Rpc.Exception_Number) is
Response : Rpc.Message_Header (Kind => Rpc.Abort_Message);
begin
if Rpc.Version_Number (Transport_Stream.Get_User_Id (Stream)) in
Rpc.Exception_Versions.First .. Rpc.Exception_Versions.Last then
Response := (Rpc.Abort_Message, Id, Rpc.Error_Server_Defined);
Rpc.Put_Message (Stream, Response);
Rpc.Put (Stream, Excep);
else
Response := (Rpc.Abort_Message, Id, Rpc.Error_Other);
Rpc.Put_Message (Stream, Response);
end if;
end Return_Exception;
procedure Serve_With_Username (Connection : Transport.Connection_Id) is
Stream : Transport_Stream.Stream_Id;
Client_Versions : Rpc.Version_Range;
Max_Version : Rpc.Version_Number;
procedure Process_Calls is
Request : Rpc.Message_Header;
function "=" (X, Y : Rpc.Message_Kind) return Boolean
renames Rpc."=";
function "=" (X, Y : Rpc.Program_Number) return Boolean
renames Rpc."=";
procedure Do_Process_Call is
procedure Put_Abort (Error : Rpc.Error_Type) is
begin
Rpc.Put_Message (Stream,
(Kind => Rpc.Abort_Message,
Id => Request.Id,
Error => Error));
end Put_Abort;
begin
if Max_Version in
Rpc.Username_Versions.First ..
Rpc.Username_Versions.Last then
declare
Username : constant String :=
Transport_Interchange.Get_String (Stream);
Password : constant String :=
Transport_Interchange.Get_String (Stream);
begin
Process_Call (Stream,
Request.Id, Request.Version, Request.Proc,
Username, Password);
end;
else
Process_Call (Stream,
Request.Id, Request.Version, Request.Proc,
Username => "",
Password => "");
end if;
exception
when Interchange.Constraint_Error =>
raise Rpc.Invalid_Argument;
when Standard.Constraint_Error =>
Put_Abort (Rpc.Error_Constraint);
when Standard.Numeric_Error =>
Put_Abort (Rpc.Error_Numeric);
when Standard.Program_Error =>
Put_Abort (Rpc.Error_Program);
when Standard.Storage_Error =>
Put_Abort (Rpc.Error_Storage);
when Standard.Tasking_Error =>
Put_Abort (Rpc.Error_Tasking);
when Io_Exceptions.Status_Error =>
Put_Abort (Rpc.Status_Error);
when Io_Exceptions.Mode_Error =>
Put_Abort (Rpc.Mode_Error);
when Io_Exceptions.Name_Error =>
Put_Abort (Rpc.Name_Error);
when Io_Exceptions.Use_Error =>
Put_Abort (Rpc.Use_Error);
when Io_Exceptions.Device_Error =>
Put_Abort (Rpc.Device_Error);
when Io_Exceptions.End_Error =>
Put_Abort (Rpc.End_Error);
when Io_Exceptions.Data_Error =>
Put_Abort (Rpc.Data_Error);
when Io_Exceptions.Layout_Error =>
Put_Abort (Rpc.Layout_Error);
when Rpc.Username_Or_Password_Error =>
Put_Abort (Rpc.Error_Username_Or_Password);
when others =>
Put_Abort (Rpc.Error_Other);
end Do_Process_Call;
procedure Put_Reject (Details : Rpc.Reject_Details) is
begin
Rpc.Put_Message (Stream,
(Kind => Rpc.Reject_Message,
Id => Request.Id,
Details => Details));
end Put_Reject;
begin
loop
Transport_Stream.Flush_Transmit_Buffer (Stream);
Request := Rpc.Get_Message (Stream);
if Request.Kind /= Rpc.Call_Message then
raise Rpc.Protocol_Error;
elsif Request.Program /= Program then
raise Rpc.No_Such_Program;
elsif not (Request.Version in
Supported.First .. Supported.Last) then
raise Rpc.No_Such_Version;
else
Do_Process_Call;
end if;
end loop;
exception
when Rpc.No_Such_Program =>
Put_Reject ((Kind => Rpc.Rej_No_Such_Program));
when Rpc.No_Such_Version =>
Put_Reject ((Kind => Rpc.Rej_No_Such_Version,
Supported => Supported));
when Rpc.No_Such_Procedure =>
Put_Reject ((Kind => Rpc.Rej_No_Such_Procedure));
when Rpc.Invalid_Argument =>
Put_Reject ((Kind => Rpc.Rej_Invalid_Argument));
when others =>
null;
end Process_Calls;
begin
Transport_Stream.Allocate (Stream, Connection);
begin
Rpc.Get (Stream, Client_Versions);
Rpc.Put (Stream, Supported_Versions);
if Rpc.Overlaps (Client_Versions, Supported_Versions) then
Max_Version := Rpc.Max (Client_Versions, Supported_Versions);
Transport_Stream.Set_User_Id -- JMK 10/24/86 for future use.
(Stream, Integer (Max_Version));
Process_Calls;
end if;
Transport_Stream.Flush_Transmit_Buffer (Stream);
exception
when others =>
null;
end;
Transport_Stream.Deallocate (Stream);
end Serve_With_Username;
procedure Serve (Connection : Transport.Connection_Id) is
procedure Ignore_Username (Stream : Transport_Stream.Stream_Id;
Id : Rpc.Transaction_Id;
Version : Rpc.Version_Number;
Proc : Rpc.Procedure_Number;
Username : String;
Password : String) is
begin
Process_Call (Stream, Id, Version, Proc);
end Ignore_Username;
procedure Guts is new Serve_With_Username
(Program, Supported, Ignore_Username);
begin
Guts (Connection);
end Serve;
end Rpc_Server;