⟦1f7ddbffa⟧

TextFile

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;
DataMuseum.dk

Rational R1000/400 Tapes

⟦1f7ddbffa⟧ TextFile

Derivation

TextFile
