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: 22517 (0x57f5) Types: TextFile Names: »B«
└─⟦bdeee703f⟧ Bits:30000538 8mm tape, Rational 1000, RWI 10_1_1 └─ ⟦545705153⟧ »DATA« └─⟦f9289093d⟧ └─⟦5f3412b64⟧ Bits:30000745 8mm tape, Rational 1000, ENVIRONMENT 12_6_5 TOOLS └─ ⟦91c658230⟧ »DATA« └─⟦f9289093d⟧ └─⟦this⟧
with Archive; with Byte_Defs; with Common; with Compilation; with Debug_Tools; with Directory_Tools; with Editor; with Enable_Product_Keymaps; with File_Transfer; with Ftp_Defs; with Ftp_Profile; with Io; with Library; with Log; with Profile; with Release; with Rwi_String; use Rwi_String; with String_Utilities; with Table_Sort_Generic; with Transport; with Transport_Defs; with Transport_Name; package body Rwi_Install is ------------------------------------------------------------------------------ -- Imported Renames ------------------------------------------------------------------------------ function "=" (A, B : Ftp_Defs.Status_Code) return Boolean renames Ftp_Defs."="; function "=" (A, B : Transport_Defs.Status_Code) return Boolean renames Transport_Defs."="; ------------------------------------------------------------------------------ -- Exceptions ------------------------------------------------------------------------------ I_Am_Confused : exception; ----I give up. Some assumption of the code has changed and the code wasn't -- changed to reflect it. Quit : exception; ----Raised when we want to give up on something. --\f function Hs (Str : String) return Heap_String is begin return new String'(Str); end Hs; --\f function Release_From_Here return String is Rel : constant String := Release.Info.R1000_Release; Wrk : constant String := Release.Info.R1000_Working; Here : constant String := Directory_Tools.Naming.Full_Name (Directory_Tools.Naming.Resolution ("$")); begin if Here'Length >= Rel'Length - 1 and then Here (Here'First .. Here'First + Rel'Length - 2) = String_Utilities.Upper_Case (Rel (Rel'First .. Rel'Last - 1)) then ----Doing a normal install. return Rel; elsif Here'Length >= Wrk'Length - 1 and then Here (Here'First .. Here'First + Wrk'Length - 2) = String_Utilities.Upper_Case (Wrk (Wrk'First .. Wrk'Last - 1)) then ----Doing a test install from development area return Release.Info.R1000_Working; else Log.Put_Line ("Please connect to: ", Profile.Error_Msg); Log.Put_Line (" " & Rel, Profile.Error_Msg); Log.Put_Line (" or to:", Profile.Error_Msg); Log.Put_Line (" " & Wrk, Profile.Error_Msg); Log.Put_Line (" and try this command again.", Profile.Error_Msg); Log.Put_Line ("Cannot run this command from " & Here, Profile.Exception_Msg); raise I_Am_Confused; end if; end Release_From_Here; --\f function Ada_Files_Generate (Keyboard : Terminal_Type) return String is ------------------------------------------------------------------------------ -- Returns the name(s) of the files in the Editor_Data area to -- compile/transfer for this Keyboard type. ------------------------------------------------------------------------------ Base : constant String := Release.Supported_Keyboards (Keyboard).Name.all & "_@"; begin return Base; end Ada_Files_Generate; --\f procedure Machine_Editor_Data_Files (Keyboard : Terminal_Type; Overrides : String := "foo=>FALSE,bar=>true") is ------------------------------------------------------------------------------ -- Keyboard - Specifies the RXI-based terminal type being installed. ------------------------------------------------------------------------------ Ada_Files : constant String := Ada_Files_Generate (Keyboard); Body_Files : constant String := Ada_Files & "'Body"; Non_Body_Files : constant String := Ada_Files & "['c(File),'Spec]"; Med : constant String := "!Machine.Editor_Data."; Tt_Filename : constant String := Med & "Terminal_Types"; Tr_Filename : constant String := Med & "Terminal_Recognition"; Tt_File : Io.File_Type; Tr_File : Io.File_Type; begin ----Say Hello. Log.Put_Line ("[Install.Machine_Editor_Data_Files(" & Terminal_Type'Image (Keyboard) & ")]", Profile.Auxiliary_Msg, Profile.Verbose); Log.Put_Line (Release_From_Here, Profile.Auxiliary_Msg, Profile.Verbose); ----Try to open the TT file for append. Errors probably indicate non-existence. Log.Put_Line ("Modify the " & Tt_Filename, Profile.Auxiliary_Msg, Profile.Verbose); begin Io.Append (Tt_File, Tt_Filename); exception when Io.Name_Error => ----Try to create the presumably non-existent file. We give up on errors. begin Io.Create (Tt_File, Io.Out_File, Tt_Filename); exception when others => Log.Put_Line ("Unexpected exception creating " & Tt_Filename & ":" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); return; end; ----Other errors cause us to give up. when others => Log.Put_Line ("Unexpected exception opening " & Tt_Filename & ":" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); return; end; ----Install our one-liner describing the terminal type. Io.Put (Tt_File, Release.Supported_Keyboards (Keyboard).Name.all); Io.Put (Tt_File, " Rational "); Io.Put (Tt_File, Release.Supported_Keyboards (Keyboard).Lines); Io.Put (Tt_File, ' '); Io.Put (Tt_File, Release.Supported_Keyboards (Keyboard).Columns); Io.New_Line (Tt_File); ----Add any extra information that may be required. if Release.Supported_Keyboards (Keyboard).Tt_Extra /= null then Io.Put_Line (Tt_File, Release.Supported_Keyboards (Keyboard).Tt_Extra.all); end if; ----Close the file. Io.Close (Tt_File); ----Try to open the TR file for append. Errors probably indicate non-existence. Log.Put_Line ("Modify the " & Tr_Filename, Profile.Auxiliary_Msg, Profile.Verbose); begin Io.Append (Tr_File, Tr_Filename); exception when Io.Name_Error => ----Try to create the presumably non-existent file. We give up on errors. begin Io.Create (Tr_File, Io.Out_File, Tr_Filename); exception when others => Log.Put_Line ("Unexpected exception creating " & Tr_Filename & ":" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); return; end; ----Other errors cause us to give up. when others => Log.Put_Line ("Unexpected exception opening " & Tr_Filename & ":" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); return; end; ----Install the one-liner and close the file. Io.Put (Tr_File, Release.Supported_Keyboards (Keyboard).Name.all); Io.Put (Tr_File, " " & Ascii.Esc); Io.Put (Tr_File, Release.Supported_Keyboards (Keyboard).Id.all); Io.Put (Tr_File, 'c'); Io.New_Line (Tr_File); Io.Close (Tr_File); ----Make sure that any 'Body's that we may be overwriting in !Machine. -- Editor_Data are in the Source state so that we don't waste time promoting -- the 'Body's twice. (Once in the Archive.Copy step and once in the -- Enable_Product_Keymaps step.) Log.Put_Line ("Install the keymap files.", Profile.Auxiliary_Msg, Profile.Verbose); begin ----See if any of the objects exist. Library.Resolve (Name_Of => "!Machine.Editor_Data." & Body_Files, Response => "<Quiet> Raise_Error"); ----Demote existing objects. Compilation.Demote (Unit => "!Machine.Editor_Data." & Body_Files, Goal => Compilation.Source, Limit => "<ALL_WORLDS>", Effort_Only => False, Response => "<Verbose> Persevere"); exception ----None of the objects exist. when Library.Error => null; end; ----Use Archive.Copy to create/replace the !Machine.Editor_Data files and to -- guarantee that they end up Source (if new) or Installed/Coded (if replacing -- old ones that were Installed/Coded). Archive.Copy (Objects => Release_From_Here & "Editor_Data." & Non_Body_Files, Use_Prefix => "!Machine.Editor_Data", For_Prefix => Release_From_Here & "Editor_Data", Options => "ALL_OBJECTS,REPLACE,REMAKE", Response => "<Verbose> Raise_Error"); Archive.Copy (Objects => Release_From_Here & "Editor_Data." & Body_Files, Use_Prefix => "!Machine.Editor_Data", For_Prefix => Release_From_Here & "Editor_Data", Options => "ALL_OBJECTS,SOURCE", Response => "<Verbose> Raise_Error"); ----Copy the Enable_Product_Keymaps procedure if it is newer than any existing -- such procedure. -- Since this Copy operation is copying a Load_Proc, and since we run the -- Code-Generator in other steps of this procedure, and since there is a bug -- in pre-Delta-3 Environments, we will run this Copy as a separate task -- as a work-around for the bug. declare task Bug_Fix is end Bug_Fix; task body Bug_Fix is begin Archive.Copy (Objects => Release_From_Here & "Editor_Data" & ".Enable_Product_Keymaps", Use_Prefix => "!Machine.Editor_Data", For_Prefix => Release_From_Here & "Editor_Data", Options => "CHANGED_OBJECTS,REPLACE,REMAKE", Response => "<Verbose> Raise_Error"); end Bug_Fix; begin null; -- Wait for task to complete. end; ----Turn on/off any product bindings and put the Editor_Data at least in -- the installed state. Log.Put_Line ("Enable product keys in keymaps.", Profile.Auxiliary_Msg, Profile.Verbose); Enable_Product_Keymaps (Keymap => "!Machine.Editor_Data." & Body_Files, Response => "<Verbose> Raise_Error", Overrides => Overrides); ----All Done. Log.Put_Line ("[end of Install.Machine_Editor_Data_Files(" & Terminal_Type'Image (Keyboard) & ")]", Profile.Auxiliary_Msg, Profile.Verbose); end Machine_Editor_Data_Files; --\f function Get_Host_Id (Name : String) return Transport_Defs.Host_Id is ------------------------------------------------------------------------------ -- Name - Specifies the name of some remote host -- Returns the Host_Id of this host or else returns an empty Host_Id if the -- name isn't known. ------------------------------------------------------------------------------ begin return Transport_Name.Host_To_Host_Id (Name); exception when Transport_Name.Undefined => return (1 .. 0 => 0); end Get_Host_Id; --\f procedure Status_Ok (Status : Transport_Defs.Status_Code) is ------------------------------------------------------------------------------ -- Status - Specifies a status to check -- Complains and raises Quit if the Status != Ok. ------------------------------------------------------------------------------ begin if Status /= Transport_Defs.Ok then Log.Put_Line ("Error in Rxi_Install: " & Transport_Defs.Image (Status), Profile.Error_Msg, Profile.Verbose); raise Quit; end if; end Status_Ok; --\f procedure Status_Ok (Status : Ftp_Defs.Status_Code) is ------------------------------------------------------------------------------ -- Status - Specifies a status to check -- Complains and raises Quit if the Status != Successful ------------------------------------------------------------------------------ begin if Status /= Ftp_Defs.Successful then Log.Put_Line ("Error in Rxi_Install: " & Ftp_Defs.Status_Code'Image (Status), Profile.Error_Msg, Profile.Verbose); raise Quit; end if; end Status_Ok; --\f procedure Response (Connection : File_Transfer.Connect_Id) is ------------------------------------------------------------------------------ -- Conection - Specifies the connection to check -- Called to read any and all Response text that has been received from the -- On_Machine host in response to any FTP command. The response text is -- send to the Log. ------------------------------------------------------------------------------ Str : String (1 .. 1000); Len : Natural; begin while not File_Transfer.End_Of_Response (Connection) loop File_Transfer.Read_Response (Connection, Str, Len); Log.Put_Line ("Ftp: " & Str (1 .. Len), Profile.Note_Msg, Profile.Verbose); end loop; end Response; --\f function Natural_Image (Val : Natural) return String is ------------------------------------------------------------------------------ -- Val - Specifies the value -- Turn a natural into a string with no leading blanks. ------------------------------------------------------------------------------ Str : constant String := Natural'Image (Val); begin return Str (Str'First + 1 .. Str'Last); end Natural_Image; --\f function Duration_Image (Time : Duration) return String is ------------------------------------------------------------------------------ -- Time - Specifies the duration -- Ada doesn't give us a nice way to turn a Fixed quantity into a string so -- we must hack one up. ------------------------------------------------------------------------------ Val : Integer := Integer (Time * Duration (1000.0)); Valsub : Natural := (abs Val) rem 1000; begin if Valsub < 10 then return Natural_Image (Val / 1000) & ".00" & Natural_Image (Valsub); elsif Valsub < 100 then return Natural_Image (Val / 1000) & ".0" & Natural_Image (Valsub); else return Natural_Image (Val / 1000) & "." & Natural_Image (Valsub); end if; end Duration_Image; --\f procedure Store (Connection : File_Transfer.Connect_Id; Local : String; Remote : String) is ------------------------------------------------------------------------------ -- Conection - Specifies the connection to use -- Local - Specifies the name of an existing local object -- Remote - Specifies the name of a remote object to be created/written -- Called to perform (and check) the transfer of one file from the R1000 to -- the On_Machine host. ------------------------------------------------------------------------------ Ftp_Status : Ftp_Defs.Status_Code; begin ----Inform the log of the impending transfer. Log.Put_Line ("--------------------------------------------------------", Profile.Note_Msg, Profile.Verbose); Log.Put_Line ("Transfer: " & Local & " => " & Remote, Profile.Note_Msg, Profile.Verbose); ----Set up a new socket connection for the actual transfer. File_Transfer.Send_Data_Port (Connection, Transport_Defs.Null_Host_Id, Transport_Defs.Null_Socket_Id); Response (Connection); File_Transfer.Command_Status (Connection, Ftp_Status); Status_Ok (Ftp_Status); ----Begin the transfer and wait for it to end. File_Transfer.Start_Store (Connection, Local_Filename => Local, Remote_Filename => Remote, Append => False); Response (Connection); File_Transfer.Command_Status (Connection, Ftp_Status); if Ftp_Status /= Ftp_Defs.Transfer_Complete then Status_Ok (Ftp_Status); end if; ----Inform the log of a successful transfer. Log.Put_Line ("Done, bytes: " & Natural_Image (File_Transfer.Last_Transfer_Length (Connection)) & ", seconds: " & Duration_Image (File_Transfer.Last_Transfer_Time (Connection)), Profile.Note_Msg, Profile.Verbose); Log.Put_Line ("--------------------------------------------------", Profile.Note_Msg, Profile.Verbose); end Store; --\f procedure Disconnect (Connection : in out File_Transfer.Connect_Id) is ------------------------------------------------------------------------------ -- Connection - Specifies the connection to destroy -- Called (at any time, in any state) when we must get rid of a connection. -- We try to do it nicely but we are prepared to ignore any errors and to -- simply drop the connection at the worst. ------------------------------------------------------------------------------ Ftp_Status : Ftp_Defs.Status_Code; begin ----If the Connection isn't "open" (really means allocated) then we have nothing -- to do. if not File_Transfer.Is_Open (Connection) then return; end if; ----If there is an actual connection then we must try to Quit out of it. if File_Transfer.Is_Connected (Connection) then begin begin File_Transfer.Send_Quit (Connection); Response (Connection); File_Transfer.Command_Status (Connection, Ftp_Status); Status_Ok (Ftp_Status); ----If the Quit fails then report that but also continue. exception when others => Log.Put_Line ("Unexpected exception during File_Transfer.Send_Quit:" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); end; ----Try to disconnect from the remote server. File_Transfer.Disconnect (Connection); exception when others => Log.Put_Line ("Unexpected exception during File_Transfer.Disconnect:" & Debug_Tools.Get_Exception_Name (True, True), Profile.Error_Msg, Profile.Verbose); end; end if; ----Finally we close (deallocate) the socket. File_Transfer.Close (Connection); end Disconnect; --\f function R1000_Form (Old_Namelc : String) return String is ------------------------------------------------------------------------------ -- Old_Namelc - Specifies a name usable by some OS other than the R1000 -- -- Called to convert a non-R1000 name into a name the R1000 can handle. -- We return the converted name. Typically we just convert "strange" -- characters into underscores ("_"). When this is a problem; at the -- beginning of a name, the end of a name, or next to another "_"; we use -- a semi-random letter; actually "A", "B", or "C". ------------------------------------------------------------------------------ Old_Name : constant String := String_Utilities.Upper_Case (Old_Namelc); New_Name : String (1 .. Old_Name'Length + 2); Oldi : Natural := Old_Name'First; Newi : Natural := New_Name'First; begin ----See if the name begins with an underscore. Prepend an A if necessary. if Old_Name (Oldi) not in 'A' .. 'Z' and then Old_Name (Oldi) not in '0' .. '9' then New_Name (Newi) := 'A'; Newi := Newi + 1; end if; ----Convert all non-letters to underscores. If this would lead to having -- two underscores adjacent then convert every 2nd underscore to a B. while Oldi <= Old_Name'Last loop if Old_Name (Oldi) not in 'A' .. 'Z' and then Old_Name (Oldi) not in '0' .. '9' then if New_Name (Newi - 1) = '_' then New_Name (Newi) := 'B'; else New_Name (Newi) := '_'; end if; else New_Name (Newi) := Old_Name (Oldi); end if; Newi := Newi + 1; Oldi := Oldi + 1; end loop; ----See if the name ends in an underscore. Append a C if necessary. if New_Name (Newi - 1) not in 'A' .. 'Z' and then New_Name (Newi - 1) not in '0' .. '9' then New_Name (Newi) := 'C'; return New_Name (New_Name'First .. Newi); else return New_Name (New_Name'First .. Newi - 1); end if; end R1000_Form; --\f end Rwi_Install;