|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 10240 (0x2800) Types: Ada Source Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Rpc_Server, seg_0009d4
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦5a81ac88f⟧ »Space Info Vol 1« └─⟦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;
nblk1=9 nid=0 hdr6=12 [0x00] rec0=19 rec1=00 rec2=01 rec3=066 [0x01] rec0=1b rec1=00 rec2=02 rec3=04a [0x02] rec0=14 rec1=00 rec2=03 rec3=03e [0x03] rec0=14 rec1=00 rec2=04 rec3=008 [0x04] rec0=14 rec1=00 rec2=05 rec3=03a [0x05] rec0=17 rec1=00 rec2=06 rec3=020 [0x06] rec0=15 rec1=00 rec2=07 rec3=072 [0x07] rec0=19 rec1=00 rec2=08 rec3=010 [0x08] rec0=07 rec1=00 rec2=09 rec3=000 tail 0x201007ce27bac64bc5b5c 0x42a00088462060003