------------------------------------------------------------------------------ -- -- -- GLADE COMPONENTS -- -- -- -- S Y S T E M . G A R L I C . O P T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1996-2020 Free Software Foundation, Inc. -- -- -- -- GARLIC is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GARLIC is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- -- -- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with GARLIC; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; use Ada.Exceptions; with Ada.Environment_Variables; use Ada.Environment_Variables; with System.Garlic.Platform_Specific; use System.Garlic.Platform_Specific; with System.Garlic.Utils; use System.Garlic.Utils; package body System.Garlic.Options is use System.Garlic.Types; -- Debugging stuff procedure Next_Argument (Index : in out Natural); function Value (S : String) return Reconnection_Type; function Value (S : String) return Termination_Type; -------------------------------- -- Initialize_Default_Options -- -------------------------------- procedure Initialize_Default_Options is begin Task_Pool_Low_Bound := Def_Task_Pool_Low_Bound; Task_Pool_High_Bound := Def_Task_Pool_High_Bound; Task_Pool_Max_Bound := Def_Task_Pool_Max_Bound; Execution_Mode := Normal_Mode; Connection_Hits := Def_Connection_Hits; Detach := False; Mirror_Expected := False; Has_A_Light_PCS := False; Is_Pure_Client := False; Is_Boot_Mirror := False; Is_Boot_Server := False; Local_Launch := Supports_Local_Launch; Nolaunch := False; Reconnection := Reject_On_Restart; Termination := Global_Termination; Rsh_Command := new String'(Platform_Specific.Rsh_Command); Rsh_Options := new String'(Platform_Specific.Rsh_Options); end Initialize_Default_Options; ----------------------------- -- Initialize_User_Options -- ----------------------------- procedure Initialize_User_Options is Index : Natural := 1; begin declare EV : constant String := Value ("BOOT_SERVER", ""); begin if EV'Length /= 0 then Set_Boot_Location (Unquote (EV)); end if; end; declare EV : constant String := Value ("BOOT_LOCATION", ""); begin if EV'Length /= 0 then Set_Boot_Location (Unquote (EV)); end if; end; declare EV : constant String := Value ("DATA_LOCATION", ""); begin if EV'Length /= 0 then Set_Data_Location (Unquote (EV)); end if; end; declare EV : constant String := Value ("CONNECTION_HITS", ""); begin if EV'Length /= 0 then Set_Connection_Hits (Natural'Value (EV)); end if; end; declare EV : constant String := Value ("DETACH", ""); begin if EV'Length /= 0 then Set_Detach (True); end if; end; declare EV : constant String := Value ("SELF_LOCATION", ""); begin if EV'Length /= 0 then Set_Self_Location (Unquote (EV)); end if; end; declare EV : constant String := Value ("BOOT_MIRROR", ""); begin if EV'Length /= 0 then Set_Boot_Mirror (True); end if; end; declare EV : constant String := Value ("NOLAUNCH", ""); begin if EV'Length /= 0 then Set_Nolaunch (True); end if; end; declare EV : constant String := Value ("SLAVE", ""); begin if EV'Length /= 0 then Set_Slave (True); end if; end; declare EV : constant String := Value ("MIRROR_EXPECTED", ""); begin if EV'Length /= 0 then Set_Mirror_Expected (True); end if; end; declare EV : constant String := Value ("RECONNECTION", ""); begin if EV'Length /= 0 then Set_Reconnection (Value (EV)); end if; end; declare EV : constant String := Value ("TERMINATION", ""); begin if EV'Length /= 0 then Set_Termination (Value (EV)); end if; end; declare EV : constant String := Value ("RSH_COMMAND", ""); begin if EV'Length /= 0 then Set_Rsh_Command (EV); end if; end; declare EV : constant String := Value ("RSH_OPTIONS", ""); begin if EV'Length /= 0 then Set_Rsh_Command (EV); end if; end; declare EV : constant String := Value ("LOCAL_LAUNCH", ""); begin if EV'Length /= 0 then Set_Local_Launch (Boolean'Value (EV)); end if; end; while Index <= Argument_Count loop if Argument (Index) = "--boot_server" then Next_Argument (Index); Set_Boot_Location (Unquote (Argument (Index))); elsif Argument (Index) = "--boot_location" then Next_Argument (Index); Set_Boot_Location (Unquote (Argument (Index))); elsif Argument (Index) = "--data_location" then Next_Argument (Index); Set_Data_Location (Unquote (Argument (Index))); elsif Argument (Index) = "--boot_mirror" then Set_Boot_Mirror (True); elsif Argument (Index) = "--mirror_expected" then Set_Mirror_Expected (True); elsif Argument (Index) = "--self_location" then Next_Argument (Index); Set_Self_Location (Unquote (Argument (Index))); elsif Argument (Index) = "--connection_hits" then Next_Argument (Index); Set_Connection_Hits (Natural'Value (Argument (Index))); elsif Argument (Index) = "--detach" then Set_Detach (True); elsif Argument (Index) = "--slave" then Set_Slave (True); elsif Argument (Index) = "--reconnection" then Next_Argument (Index); Set_Reconnection (Value (Argument (Index))); elsif Argument (Index) = "--termination" then Next_Argument (Index); Set_Termination (Value (Argument (Index))); elsif Argument (Index) = "--rsh-command" then Next_Argument (Index); Set_Rsh_Command (Argument (Index)); elsif Argument (Index) = "--rsh-options" then Next_Argument (Index); Set_Rsh_Options (Argument (Index)); elsif Argument (Index) = "--nolaunch" then Set_Nolaunch (True); elsif Argument (Index) = "--trace" then Set_Execution_Mode (Trace_Mode); elsif Argument (Index) = "--replay" then Set_Execution_Mode (Replay_Mode); elsif Argument (Index) = "--local-launch" then Next_Argument (Index); Set_Local_Launch (Boolean'Value (Argument (Index))); end if; Index := Index + 1; end loop; if Is_Boot_Server then Is_Boot_Mirror := True; end if; if Is_Boot_Server and then Self_Location /= null then if Boot_Location = null then Boot_Location := Copy (Self_Location); else -- For the boot partition, boot locations are also self -- locations. They have to be appended to the current -- self locations because they are not the prefered -- locations. declare All_Locations : constant String := Merge_String (Self_Location) & " " & Merge_String (Boot_Location); begin Set_Self_Location (All_Locations); end; end if; end if; if Boot_Location = null then declare No_Default_Protocol_Name : constant Boolean := Default_Protocol_Name'Length = 0; begin if (Is_Boot_Server and then not Nolaunch) or else No_Default_Protocol_Name then Set_Boot_Location ("tcp"); else Set_Boot_Location (Default_Protocol_Name & "://" & Default_Protocol_Data); end if; end; end if; if Self_Location = null then if Is_Boot_Server then Self_Location := Copy (Boot_Location); else Self_Location := new String_List'(1 .. 1 => new String'(Default_Protocol_Name)); end if; end if; if Data_Location = null then Data_Location := new String_List'(1 .. 1 => new String'(Default_Storage_Name & "://" & Default_Storage_Data)); end if; end Initialize_User_Options; ------------------- -- Next_Argument -- ------------------- procedure Next_Argument (Index : in out Natural) is begin if Index = Argument_Count then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Missing argument on command line"); end if; Index := Index + 1; end Next_Argument; ----------------------- -- Set_Boot_Location -- ----------------------- procedure Set_Boot_Location (Default : String) is begin Destroy (Boot_Location); Boot_Location := Split_String (Default); end Set_Boot_Location; --------------------- -- Set_Boot_Mirror -- --------------------- procedure Set_Boot_Mirror (Default : Boolean) is begin if Is_Boot_Mirror and then not Default then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition is already a boot mirror partition"); end if; if Default and then Has_A_Light_PCS then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition with light PCS cannot be a boot mirror"); end if; Is_Boot_Mirror := True; end Set_Boot_Mirror; ------------------------- -- Set_Connection_Hits -- ------------------------- procedure Set_Connection_Hits (Default : Natural) is begin Connection_Hits := Default; end Set_Connection_Hits; ----------------------- -- Set_Data_Location -- ----------------------- procedure Set_Data_Location (Default : String) is begin Destroy (Data_Location); Data_Location := Split_String (Default); end Set_Data_Location; ---------------- -- Set_Detach -- ---------------- procedure Set_Detach (Default : Boolean) is begin Detach := Default; end Set_Detach; ------------------------ -- Set_Execution_Mode -- ------------------------ procedure Set_Execution_Mode (Default : Execution_Mode_Type) is begin Execution_Mode := Default; end Set_Execution_Mode; ------------------- -- Set_Light_PCS -- ------------------- procedure Set_Light_PCS (Default : Boolean) is begin if Has_A_Light_PCS and then not Default then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition is configured for a light PCS"); end if; if Default then if Termination /= Local_Termination then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition with light PCS must have a local termination"); elsif Is_Boot_Mirror then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition with light PCS cannot be a boot mirror partition"); end if; Set_Pure_Client (True); end if; Has_A_Light_PCS := Default; end Set_Light_PCS; ---------------------- -- Set_Local_Launch -- ---------------------- procedure Set_Local_Launch (Default : Boolean) is begin Local_Launch := Default; end Set_Local_Launch; ------------------------- -- Set_Mirror_Expected -- ------------------------- procedure Set_Mirror_Expected (Default : Boolean) is begin Mirror_Expected := Default; end Set_Mirror_Expected; ------------------ -- Set_Nolaunch -- ------------------ procedure Set_Nolaunch (Default : Boolean) is begin Nolaunch := Default; end Set_Nolaunch; ------------------------ -- Set_Partition_Name -- ------------------------ procedure Set_Partition_Name (Name : String) is begin if Partition_Name /= null then Destroy (Partition_Name); end if; Partition_Name := new String'(Name); Set_Trace_File_Name (Name & ".ptf"); end Set_Partition_Name; --------------------- -- Set_Pure_Client -- --------------------- procedure Set_Pure_Client (Default : Boolean) is begin if Is_Pure_Client and then not Default then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition is configured as a pure client"); end if; if Has_A_Light_PCS and then not Default then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition is configured with a light PCS"); end if; Is_Pure_Client := Default; end Set_Pure_Client; ---------------------- -- Set_Reconnection -- ---------------------- procedure Set_Reconnection (Default : Reconnection_Type) is begin Reconnection := Default; end Set_Reconnection; --------------------- -- Set_Rsh_Command -- --------------------- procedure Set_Rsh_Command (Default : String) is begin if Rsh_Command /= null then Destroy (Rsh_Command); end if; Rsh_Command := new String'(Default); end Set_Rsh_Command; --------------------- -- Set_Rsh_Options -- --------------------- procedure Set_Rsh_Options (Default : String) is begin if Rsh_Options /= null then Destroy (Rsh_Options); end if; Rsh_Options := new String'(Default); end Set_Rsh_Options; ----------------------- -- Set_Self_Location -- ----------------------- procedure Set_Self_Location (Default : String) is begin Destroy (Self_Location); Self_Location := Split_String (Default); end Set_Self_Location; --------------- -- Set_Slave -- --------------- procedure Set_Slave (Default : Boolean) is begin Is_Boot_Server := not Default; end Set_Slave; -------------------------- -- Set_Task_Pool_Bounds -- -------------------------- procedure Set_Task_Pool_Bounds (Low, High, Max : Positive) is begin Task_Pool_Low_Bound := Low; Task_Pool_High_Bound := High; Task_Pool_Max_Bound := Max; end Set_Task_Pool_Bounds; --------------------- -- Set_Termination -- --------------------- procedure Set_Termination (Default : Termination_Type) is begin if Has_A_Light_PCS and then Default /= Local_Termination then Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Partition with light PCS must have a local termination"); end if; Termination := Default; end Set_Termination; ------------------------- -- Set_Trace_File_Name -- ------------------------- procedure Set_Trace_File_Name (Name : String) is begin if Trace_File_Name /= null then Destroy (Trace_File_Name); end if; Trace_File_Name := new String'(Name); end Set_Trace_File_Name; ----------- -- Value -- ----------- function Value (S : String) return Reconnection_Type is begin return Reconnection_Type'Value (S); exception when others => Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Unknown reconnection mode """ & S & """"); end Value; ----------- -- Value -- ----------- function Value (S : String) return Termination_Type is begin return Termination_Type'Value (S); exception when others => Ada.Exceptions.Raise_Exception (Program_Error'Identity, "Unknown termination mode """ & S & """"); end Value; end System.Garlic.Options;