-----------------------------------------------------------------------
--  asf.beans -- Bean Registration and Factory
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Beans.Objects.Maps;
package body ASF.Beans is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Beans");

   --  ------------------------------
   --  Register under the name identified by Name the class instance Class.
   --  ------------------------------
   procedure Register_Class (Factory : in out Bean_Factory;
                             Name    : in String;
                             Class   : in Class_Binding_Access) is
   begin
      Log.Info ("Register bean class {0}", Name);

      Factory.Registry.Include (Name, Class_Binding_Ref.Create (Class));
   end Register_Class;

   --  ------------------------------
   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   --  ------------------------------
   procedure Register_Class (Factory : in out Bean_Factory;
                             Name    : in String;
                             Handler : in Create_Bean_Access) is
      Class : constant Default_Class_Binding_Access := new Default_Class_Binding;
   begin
      Class.Create := Handler;
      Register_Class (Factory, Name, Class.all'Access);
   end Register_Class;

   --  ------------------------------
   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
   begin
      Log.Info ("Register bean '{0}' created by '{1}' in scope {2}",
                Name, Class, Scope_Type'Image (Scope));

      declare
         Pos     : constant Registry_Maps.Cursor := Factory.Registry.Find (Class);
         Binding : Bean_Binding;
      begin
         if not Registry_Maps.Has_Element (Pos) then
            Log.Error ("Class '{0}' does not exist.  Cannot register bean '{1}'",
                       Class, Name);
            return;
         end if;
         Binding.Create := Registry_Maps.Element (Pos);
         Binding.Scope  := Scope;
         Binding.Params := Params;
         Factory.Map.Include (Ada.Strings.Unbounded.To_Unbounded_String (Name), Binding);
      end;
   end Register;

   --  ------------------------------
   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Class   : in Class_Binding_Access;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
      Binding : Bean_Binding;
   begin
      Log.Info ("Register bean '{0}' in scope {2}",
                Name, Scope_Type'Image (Scope));

      Binding.Create := Class_Binding_Ref.Create (Class);
      Binding.Scope  := Scope;
      Binding.Params := Params;
      Factory.Map.Include (Ada.Strings.Unbounded.To_Unbounded_String (Name), Binding);
   end Register;

   --  ------------------------------
   --  Register all the definitions from a factory to a main factory.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       From    : in Bean_Factory) is
   begin
      declare
         Pos : Registry_Maps.Cursor := From.Registry.First;
      begin
         while Registry_Maps.Has_Element (Pos) loop
            Factory.Registry.Include (Key      => Registry_Maps.Key (Pos),
                                      New_Item => Registry_Maps.Element (Pos));
            Registry_Maps.Next (Pos);
         end loop;
      end;
      declare
         Pos : Bean_Maps.Cursor := Bean_Maps.First (From.Map);
      begin
         while Bean_Maps.Has_Element (Pos) loop
            Factory.Map.Include (Key      => Bean_Maps.Key (Pos),
                                 New_Item => Bean_Maps.Element (Pos));
            Bean_Maps.Next (Pos);
         end loop;
      end;
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (Factory : in Bean_Factory;
                     Name    : in Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type) is
      use type Util.Beans.Basic.Readonly_Bean_Access;
      Pos : constant Bean_Maps.Cursor := Factory.Map.Find (Name);
   begin
      if Bean_Maps.Has_Element (Pos) then
         declare
            Binding : constant Bean_Binding := Bean_Maps.Element (Pos);
         begin
            Binding.Create.Value.Create (Name, Result);
            if Result /= null and then not Binding.Params.Is_Null then
               if Result.all in Util.Beans.Basic.Bean'Class then
                  EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Result.all),
                                       Binding.Params.Value.Params,
                                       Context);
               else
                  Log.Warn ("Bean {0} cannot be set with pre-defined properties as it does "
                            & "not implement the Bean interface", To_String (Name));
               end if;
            end if;
            Scope := Binding.Scope;
         end;
      else
         Result := null;
         Scope := ANY_SCOPE;
      end if;
   end Create;

   --  ------------------------------
   --  Create a bean by using the registered create function.
   --  ------------------------------
   procedure Create (Factory : in Default_Class_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
   begin
      Result := Factory.Create.all;
   end Create;

   --  ------------------------------
   --  Create a map bean object that allows to associate name/value pairs in a bean.
   --  ------------------------------
   function Create_Map_Bean return Util.Beans.Basic.Readonly_Bean_Access is
   begin
      return new Util.Beans.Objects.Maps.Map_Bean;
   end Create_Map_Bean;

end ASF.Beans;

-----------------------------------------------------------------------
--  asf.beans -- Bean Registration and Factory
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Beans.Objects.Maps;
package body ASF.Beans is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Beans");

   --  ------------------------------
   --  Register under the name identified by Name the class instance Class.
   --  ------------------------------
   procedure Register_Class (Factory : in out Bean_Factory;
                             Name    : in String;
                             Class   : in Class_Binding_Access) is
   begin
      Log.Info ("Register bean class {0}", Name);

      Factory.Registry.Include (Name, Class_Binding_Ref.Create (Class));
   end Register_Class;

   --  ------------------------------
   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   --  ------------------------------
   procedure Register_Class (Factory : in out Bean_Factory;
                             Name    : in String;
                             Handler : in Create_Bean_Access) is
      Class : constant Default_Class_Binding_Access := new Default_Class_Binding;
   begin
      Class.Create := Handler;
      Register_Class (Factory, Name, Class.all'Access);
   end Register_Class;

   --  ------------------------------
   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
   begin
      Log.Info ("Register bean '{0}' created by '{1}' in scope {2}",
                Name, Class, Scope_Type'Image (Scope));

      declare
         Pos     : constant Registry_Maps.Cursor := Factory.Registry.Find (Class);
         Binding : Bean_Binding;
      begin
         if not Registry_Maps.Has_Element (Pos) then
            Log.Error ("Class '{0}' does not exist.  Cannot register bean '{1}'",
                       Class, Name);
            return;
         end if;
         Binding.Create := Registry_Maps.Element (Pos);
         Binding.Scope  := Scope;
         Binding.Params := Params;
         Factory.Map.Include (Ada.Strings.Unbounded.To_Unbounded_String (Name), Binding);
      end;
   end Register;

   --  ------------------------------
   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       Name    : in String;
                       Class   : in Class_Binding_Access;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE) is
      Binding : Bean_Binding;
   begin
      Log.Info ("Register bean '{0}' in scope {1}",
                Name, Scope_Type'Image (Scope));

      Binding.Create := Class_Binding_Ref.Create (Class);
      Binding.Scope  := Scope;
      Binding.Params := Params;
      Factory.Map.Include (Ada.Strings.Unbounded.To_Unbounded_String (Name), Binding);
   end Register;

   --  ------------------------------
   --  Register all the definitions from a factory to a main factory.
   --  ------------------------------
   procedure Register (Factory : in out Bean_Factory;
                       From    : in Bean_Factory) is
   begin
      declare
         Pos : Registry_Maps.Cursor := From.Registry.First;
      begin
         while Registry_Maps.Has_Element (Pos) loop
            Factory.Registry.Include (Key      => Registry_Maps.Key (Pos),
                                      New_Item => Registry_Maps.Element (Pos));
            Registry_Maps.Next (Pos);
         end loop;
      end;
      declare
         Pos : Bean_Maps.Cursor := Bean_Maps.First (From.Map);
      begin
         while Bean_Maps.Has_Element (Pos) loop
            Factory.Map.Include (Key      => Bean_Maps.Key (Pos),
                                 New_Item => Bean_Maps.Element (Pos));
            Bean_Maps.Next (Pos);
         end loop;
      end;
   end Register;

   --  ------------------------------
   --  Create a bean by using the create operation registered for the name
   --  ------------------------------
   procedure Create (Factory : in Bean_Factory;
                     Name    : in Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type) is
      use type Util.Beans.Basic.Readonly_Bean_Access;
      Pos : constant Bean_Maps.Cursor := Factory.Map.Find (Name);
   begin
      if Bean_Maps.Has_Element (Pos) then
         declare
            Binding : constant Bean_Binding := Bean_Maps.Element (Pos);
         begin
            Binding.Create.Value.Create (Name, Result);
            if Result /= null and then not Binding.Params.Is_Null then
               if Result.all in Util.Beans.Basic.Bean'Class then
                  EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Result.all),
                                       Binding.Params.Value.Params,
                                       Context);
               else
                  Log.Warn ("Bean {0} cannot be set with pre-defined properties as it does "
                            & "not implement the Bean interface", To_String (Name));
               end if;
            end if;
            Scope := Binding.Scope;
         end;
      else
         Result := null;
         Scope := ANY_SCOPE;
      end if;
   end Create;

   --  ------------------------------
   --  Create a bean by using the registered create function.
   --  ------------------------------
   procedure Create (Factory : in Default_Class_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
   begin
      Result := Factory.Create.all;
   end Create;

   --  ------------------------------
   --  Create a map bean object that allows to associate name/value pairs in a bean.
   --  ------------------------------
   function Create_Map_Bean return Util.Beans.Basic.Readonly_Bean_Access is
   begin
      return new Util.Beans.Objects.Maps.Map_Bean;
   end Create_Map_Bean;

end ASF.Beans;

Fix log when a bean is registered

Fix log when a bean is registered


--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Orka.SIMD;

generic
   type Element_Type is digits <>;
   type Vector_Type is array (SIMD.Index_Homogeneous) of Element_Type;
   with function "*" (Left, Right : Vector_Type) return Vector_Type;
   with function Add_Vectors (Left, Right : Vector_Type) return Vector_Type;
   with function Subtract_Vectors (Left, Right : Vector_Type) return Vector_Type;
   with function Minus_Vector (Elements : Vector_Type) return Vector_Type;
   with function Absolute_Vector (Elements : Vector_Type) return Vector_Type;
   with function Sum (Elements : Vector_Type) return Element_Type;
   with function Divide_Or_Zero (Left, Right : Vector_Type) return Vector_Type;
   with function Cross_Product (Left, Right : Vector_Type) return Vector_Type;
package Orka.Transforms.SIMD_Vectors is
   pragma Preelaborate;

   subtype Vector4 is Vector_Type;

   function Zero_Value return Vector_Type is
     ((0.0, 0.0, 0.0, 0.0))
   with Inline;

   function "+" (Left, Right : Vector_Type) return Vector_Type renames Add_Vectors;

   function "-" (Left, Right : Vector_Type) return Vector_Type renames Subtract_Vectors;

   function "-" (Elements : Vector_Type) return Vector_Type renames Minus_Vector;

   function "abs" (Elements : Vector_Type) return Vector_Type renames Absolute_Vector;

   function "*" (Factor : Element_Type; Elements : Vector_Type) return Vector_Type;

   function "*" (Elements : Vector_Type; Factor : Element_Type) return Vector_Type;

   function Magnitude2 (Elements : Vector_Type) return Element_Type
     with Inline;

   function Magnitude (Elements : Vector_Type) return Element_Type;

   function Normalize (Elements : Vector_Type) return Vector_Type;

   function Normalized (Elements : Vector_Type) return Boolean;

   function Distance (Left, Right : Vector_Type) return Element_Type;

   function Projection (Elements, Direction : Vector_Type) return Vector_Type;

   function Perpendicular (Elements, Direction : Vector_Type) return Vector_Type;

   function Angle (Left, Right : Vector_Type) return Element_Type;

   function Dot (Left, Right : Vector_Type) return Element_Type;

   function Cross (Left, Right : Vector_Type) return Vector_Type renames Cross_Product;

end Orka.Transforms.SIMD_Vectors;

--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Orka.SIMD;

generic
   type Element_Type is digits <>;
   type Vector_Type is array (SIMD.Index_Homogeneous) of Element_Type;
   with function "*" (Left, Right : Vector_Type) return Vector_Type;
   with function Add_Vectors (Left, Right : Vector_Type) return Vector_Type;
   with function Subtract_Vectors (Left, Right : Vector_Type) return Vector_Type;
   with function Minus_Vector (Elements : Vector_Type) return Vector_Type;
   with function Absolute_Vector (Elements : Vector_Type) return Vector_Type;
   with function Sum (Elements : Vector_Type) return Element_Type;
   with function Divide_Or_Zero (Left, Right : Vector_Type) return Vector_Type;
   with function Cross_Product (Left, Right : Vector_Type) return Vector_Type;
package Orka.Transforms.SIMD_Vectors is
   pragma Preelaborate;

   subtype Vector4 is Vector_Type;

   function Zero_Direction return Vector_Type is
     ((0.0, 0.0, 0.0, 0.0))
   with Inline;

   function Zero_Point return Vector_Type is
     ((0.0, 0.0, 0.0, 1.0))
   with Inline;

   function "+" (Left, Right : Vector_Type) return Vector_Type renames Add_Vectors;

   function "-" (Left, Right : Vector_Type) return Vector_Type renames Subtract_Vectors;

   function "-" (Elements : Vector_Type) return Vector_Type renames Minus_Vector;

   function "abs" (Elements : Vector_Type) return Vector_Type renames Absolute_Vector;

   function "*" (Factor : Element_Type; Elements : Vector_Type) return Vector_Type;

   function "*" (Elements : Vector_Type; Factor : Element_Type) return Vector_Type;

   function Magnitude2 (Elements : Vector_Type) return Element_Type
     with Inline;

   function Magnitude (Elements : Vector_Type) return Element_Type;

   function Normalize (Elements : Vector_Type) return Vector_Type;

   function Normalized (Elements : Vector_Type) return Boolean;

   function Distance (Left, Right : Vector_Type) return Element_Type;

   function Projection (Elements, Direction : Vector_Type) return Vector_Type;

   function Perpendicular (Elements, Direction : Vector_Type) return Vector_Type;

   function Angle (Left, Right : Vector_Type) return Element_Type;

   function Dot (Left, Right : Vector_Type) return Element_Type;

   function Cross (Left, Right : Vector_Type) return Vector_Type renames Cross_Product;

end Orka.Transforms.SIMD_Vectors;

orka: Replace Zero_Value with Zero_Direction and Zero_Point

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  factory -- Session Factory
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ADO.Sequences;
with ADO.Caches;
with ADO.Sessions.Sources;

--  == Session Factory ==
--  The session factory is the entry point to obtain a database session.
--  The `ADO.Sessions.Factory` package defines the factory for creating
--  sessions.
--
--    with ADO.Sessions.Factory;
--    ...
--    Sess_Factory : ADO.Sessions.Factory;
--
--  The session factory can be initialized by using the `Create` operation and
--  by giving a URI string that identifies the driver and the information to connect
--  to the database.  The session factory is created only once when the application starts.
--
--    ADO.Sessions.Factory.Create (Sess_Factory, "mysql://localhost:3306/ado_test?user=test");
--
--  Having a session factory, one can get a database by using the `Get_Session` or
--  `Get_Master_Session` function.  Each time this operation is called, a new session
--  is returned.  The session is released when the session variable is finalized.
--
--    DB : ADO.Sessions.Session := Sess_Factory.Get_Session;
--
--  The session factory is also responsible for maintaining some data that is shared by
--  all the database connections.  This includes:
--
--    * the sequence generators used to allocate unique identifiers for database tables,
--    * the entity cache,
--    * some application specific global cache.
--
package ADO.Sessions.Factory is

   pragma Elaborate_Body;

   ENTITY_CACHE_NAME : constant String := "entity_type";

   --  ------------------------------
   --  Session factory
   --  ------------------------------
   type Session_Factory is tagged limited private;
   type Session_Factory_Access is access all Session_Factory'Class;

   --  Get a read-only session from the factory.
   function Get_Session (Factory : in Session_Factory) return Session;

   --  Get a read-write session from the factory.
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session;

   --  Open a session
   procedure Open_Session (Factory : in out Session_Factory;
                           Database : out Session);

   --  Open a session
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session);

   --  Create the session factory to connect to the database represented
   --  by the data source.
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source);

   --  Create the session factory to connect to the database identified
   --  by the URI.
   procedure Create (Factory : out Session_Factory;
                     URI     : in String);

   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   function Get_Session (Proxy : in Session_Record_Access) return Session;
private

   --  The session factory holds the necessary information to obtain a master or slave
   --  database connection.  The sequence factory is shared by all sessions of the same
   --  factory (implementation is thread-safe).  The factory also contains the entity type
   --  cache which is initialized when the factory is created.
   type Session_Factory is tagged limited record
      Source       : ADO.Sessions.Sources.Data_Source;
      Sequences    : Factory_Access := null;
      Seq_Factory  : aliased ADO.Sequences.Factory;
      --  Entity_Cache : aliased ADO.Schemas.Entities.Entity_Cache;
      Entities     : ADO.Sessions.Entity_Cache_Access := null;
      Cache        : aliased ADO.Caches.Cache_Manager;
      Cache_Values : ADO.Caches.Cache_Manager_Access;
      Queries      : ADO.Queries.Query_Manager_Access;
   end record;

   --  Initialize the sequence factory associated with the session factory.
   procedure Initialize_Sequences (Factory : in out Session_Factory);

end ADO.Sessions.Factory;

-----------------------------------------------------------------------
--  factory -- Session Factory
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ADO.Sequences;
with ADO.Caches;
with ADO.Sessions.Sources;

--  == Session Factory ==
--  The session factory is the entry point to obtain a database session.
--  The `ADO.Sessions.Factory` package defines the factory for creating
--  sessions.
--
--    with ADO.Sessions.Factory;
--    ...
--    Sess_Factory : ADO.Sessions.Factory;
--
--  The session factory can be initialized by using the `Create` operation and
--  by giving a URI string that identifies the driver and the information to connect
--  to the database.  The session factory is created only once when the application starts.
--
--    ADO.Sessions.Factory.Create (Sess_Factory, "mysql://localhost:3306/ado_test?user=test");
--
--  Having a session factory, one can get a database by using the `Get_Session` or
--  `Get_Master_Session` function.  Each time this operation is called, a new session
--  is returned.  The session is released when the session variable is finalized.
--
--    DB : ADO.Sessions.Session := Sess_Factory.Get_Session;
--
--  The session factory is also responsible for maintaining some data that is shared by
--  all the database connections.  This includes:
--
--    * the sequence generators used to allocate unique identifiers for database tables,
--    * the entity cache,
--    * some application specific global cache.
--
package ADO.Sessions.Factory is

   pragma Elaborate_Body;

   ENTITY_CACHE_NAME : constant String := "entity_type";

   --  ------------------------------
   --  Session factory
   --  ------------------------------
   type Session_Factory is tagged limited private;
   type Session_Factory_Access is access all Session_Factory'Class;

   --  Get a read-only session from the factory.
   function Get_Session (Factory : in Session_Factory) return Session;

   --  Get a read-write session from the factory.
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session;

   --  Open a session
   procedure Open_Session (Factory : in out Session_Factory;
                           Database : out Session);

   --  Open a session
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session);

   --  Create the session factory to connect to the database represented
   --  by the data source.
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source);

   --  Create the session factory to connect to the database identified
   --  by the URI.
   procedure Create (Factory : out Session_Factory;
                     URI     : in String);

   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   function Get_Session (Proxy : in Session_Record_Access) return Session;
private

   --  The session factory holds the necessary information to obtain a master or slave
   --  database connection.  The sequence factory is shared by all sessions of the same
   --  factory (implementation is thread-safe).  The factory also contains the entity type
   --  cache which is initialized when the factory is created.
   type Session_Factory is tagged limited record
      Source       : ADO.Sessions.Sources.Data_Source;
      Sequences    : Factory_Access := null;
      Seq_Factory  : aliased ADO.Sequences.Factory;
      --  Entity_Cache : aliased ADO.Schemas.Entities.Entity_Cache;
      Entities     : ADO.Sessions.Entity_Cache_Access := null;
      Cache        : aliased ADO.Caches.Cache_Manager;
      Cache_Values : ADO.Caches.Cache_Manager_Access;
      Queries      : aliased ADO.Queries.Query_Manager;
   end record;

   --  Initialize the sequence factory associated with the session factory.
   procedure Initialize_Sequences (Factory : in out Session_Factory);

end ADO.Sessions.Factory;

Replace the Query_Manager_Access by a Query_Manager


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 2017, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;

with Ada.IO_Exceptions;

package body ADO.Drivers is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Drivers");

   --  Global configuration properties (loaded by Initialize).
   Global_Config : Util.Properties.Manager;

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      Log.Info ("Initialize using property file {0}", Config);

      begin
         Util.Properties.Load_Properties (Global_Config, Config);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Configuration file '{0}' does not exist", Config);
      end;

      Initialize (Global_Config);
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      Global_Config := Util.Properties.Manager (Config);

      --  Initialize the drivers.
      ADO.Drivers.Initialize;
   end Initialize;

   --  ------------------------------
   --  Get the global configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Name    : in String;
                        Default : in String := "") return String is
   begin
      return Global_Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Returns true if the global configuration property is set to true/on.
   --  ------------------------------
   function Is_On (Name   : in String) return Boolean is
      Value : constant String := Global_Config.Get (Name, "");
   begin
      return Value = "on" or Value = "true" or Value = "1";
   end Is_On;

   --  Initialize the drivers which are available.
   procedure Initialize is separate;

end ADO.Drivers;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ADO.Configs;

package body ADO.Drivers is

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      ADO.Configs.Initialize (Config);
      ADO.Drivers.Initialize;
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      ADO.Configs.Initialize (Config);

      --  Initialize the drivers.
      ADO.Drivers.Initialize;
   end Initialize;

   --  Initialize the drivers which are available.
   procedure Initialize is separate;

end ADO.Drivers;

Remove Database_Error, Driver_Index, Get_Config, Is_On to avoid confusion with operations in ADO.Configs package


with Nanomsg.Socket;
with Interfaces.C;

package body Nanomsg.Socket_Pools is
   procedure Add_Socket (Self   : in out Pool_T;
                         Socket : in     Nanomsg.Socket.Socket_T) is
   begin
      Pool_Container_P.Insert (Self.Pool, Socket.Get_Fd, Socket);
   end Add_Socket;

   procedure Remove_Socket (Self   : in out Pool_T;
                            Socket : in     Nanomsg.Socket.Socket_T) is
   begin
      Pool_Container_P.Delete (Self.Pool, Socket.Get_Fd);
   end Remove_Socket;

   function Check_Pool (Self    : in Pool_T;
                        Send    : in Boolean;
                        Receive : in Boolean) return Pool_T is
      Retval : Pool_T;
      package C renames Interfaces.C;
      type Flags_T is mod 2**C.Short'Size with Size => C.Short'Size;
      nn_pollin  :  constant Flags_T := 1;
      nn_pollout :  constant Flags_T := 2;

      type Nn_Poll_T is record
         Fd      : C.Int;
         Events  : C.Short;
         Revents : C.Short;
      end record with Convention => C;

      type Nn_Poll_Array_T is array (1 .. Pool_Container_P.Length (Self.Pool)) of Nn_Poll_T with Convention => C;

      type Nn_Poll_Array_Access_T is access all Nn_Poll_Array_T with Convention => C;

      -- int nn_poll (struct nn_pollfd *fds, int nfds, int timeout);
      function Nn_Poll (Fds     : in out Nn_Poll_Array_T;
                        Nfds    :        C.Int;
                        Timeout :        C.Int) return C.Int
      with Import, Convention => C , External_Name => "nn_poll";

      Req       : Nn_Poll_Array_T;
      In_Flags  : C.Short := C.Short ((if Send then NN_Pollout else 0) or (if Receive then NN_Pollin else 0));
      Out_Flags : C.Short := 0;
      use type C.Int;

   begin
      declare
         Position :  Pool_Container_P.Cursor := Pool_Container_P.First (Self.Pool);
      begin
         for Index in Req'Range loop
            Req (Index) := (Fd      => C.Int (Pool_Container_P.Key (Position)),
                            Events  => In_Flags,
                            Revents => Out_Flags);
         end loop;
      end;

      if Nn_Poll (Req,  Req'Length,  1000) < 0 then
         raise Nanomsg.Socket.Socket_Exception with "Nn_Poll failed";
      end if;

      for Element of Req loop
         declare
            Result : Flags_T := Flags_T (Element.Revents);
         begin
            if Send and then Receive then
               if (Result and (Nn_Pollin or Nn_Pollout)) = (Nn_Pollin or Nn_Pollout) then
                  Pool_Container_P.Insert (Container => Retval.Pool,
                                           Key       => Integer (Element.Fd),
                                           New_Item  => Pool_Container_P.Element (Container => Self.Pool,
                                                                                Key => Integer (Element.Fd)));
               end if;
            else
               declare
               Is_Matched  : Boolean := (Result and (if Send then Nn_Pollout else Nn_Pollin)) = (if Send then Nn_Pollout else Nn_Pollin);
               begin
                  if Is_Matched then
                     Pool_Container_P.Insert (Container => Retval.Pool,
                                              Key       => Integer (Element.Fd),
                                              New_Item  => Pool_Container_P.Element (Container => Self.Pool,
                                                                                Key => Integer (Element.Fd)));

                  end if;
               end ;

            end if;
         end;
      end loop;
      return Retval;
   end Check_Pool;

   function Has_Message (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => True, Send => False);
   end Has_Message;

   function Ready_To_Send (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => False, Send => True);
   end Ready_To_Send;

   function Ready_To_Send_Receive (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => True, Send => True);
   end Ready_To_Send_Receive;

   function Has_Socket (Self   : in Pool_T;
                        Socket : in Nanomsg.Socket.Socket_T) return Boolean is (Pool_Container_P.Contains (Self.Pool, Socket.Get_Fd));

end Nanomsg.Socket_Pools;

with Nanomsg.Socket;
with Interfaces.C;

package body Nanomsg.Socket_Pools is
   procedure Add_Socket (Self   : in out Pool_T;
                         Socket : in     Nanomsg.Socket.Socket_T) is
   begin
      Pool_Container_P.Insert (Self.Pool, Socket.Get_Fd, Socket);
   end Add_Socket;

   procedure Remove_Socket (Self   : in out Pool_T;
                            Socket : in     Nanomsg.Socket.Socket_T) is
   begin
      Pool_Container_P.Delete (Self.Pool, Socket.Get_Fd);
   end Remove_Socket;

   function Check_Pool (Self    : in Pool_T;
                        Send    : in Boolean;
                        Receive : in Boolean) return Pool_T is
      Retval : Pool_T;
      package C renames Interfaces.C;
      type Flags_T is mod 2**C.Short'Size with Size => C.Short'Size;
      nn_pollin  :  constant Flags_T := 1;
      nn_pollout :  constant Flags_T := 2;

      type Nn_Poll_T is record
         Fd      : C.Int;
         Events  : C.Short;
         Revents : C.Short;
      end record with Convention => C;

      type Nn_Poll_Array_T is array (1 .. Pool_Container_P.Length (Self.Pool)) of Nn_Poll_T with Convention => C;

      type Nn_Poll_Array_Access_T is access all Nn_Poll_Array_T with Convention => C;

      -- int nn_poll (struct nn_pollfd *fds, int nfds, int timeout);
      function Nn_Poll (Fds     : in out Nn_Poll_Array_T;
                        Nfds    :        C.Int;
                        Timeout :        C.Int) return C.Int
      with Import, Convention => C , External_Name => "nn_poll";

      Req        : Nn_Poll_Array_T;
      In_Flags   : C.Short := C.Short ((if Send then NN_Pollout else 0) or (if Receive then NN_Pollin else 0));
      Out_Flags  : C.Short := 0;
      Req_Length : Natural := Req'Length;
      use type C.Int;

   begin
      declare
         Position :  Pool_Container_P.Cursor := Pool_Container_P.First (Self.Pool);
      begin
         for Index in Req'Range loop
            Req (Index) := (Fd      => C.Int (Pool_Container_P.Key (Position)),
                            Events  => In_Flags,
                            Revents => Out_Flags);
         end loop;
      end;

      if Nn_Poll (Req,  C.Int (Req_Length),  1000) < 0 then
         raise Nanomsg.Socket.Socket_Exception with "Nn_Poll failed";
      end if;

      for Element of Req loop
         declare
            Result : Flags_T := Flags_T (Element.Revents);
         begin
            if Send and then Receive then
               if (Result and (Nn_Pollin or Nn_Pollout)) = (Nn_Pollin or Nn_Pollout) then
                  Pool_Container_P.Insert (Container => Retval.Pool,
                                           Key       => Integer (Element.Fd),
                                           New_Item  => Pool_Container_P.Element (Container => Self.Pool,
                                                                                Key => Integer (Element.Fd)));
               end if;
            else
               declare
               Is_Matched  : Boolean := (Result and (if Send then Nn_Pollout else Nn_Pollin)) = (if Send then Nn_Pollout else Nn_Pollin);
               begin
                  if Is_Matched then
                     Pool_Container_P.Insert (Container => Retval.Pool,
                                              Key       => Integer (Element.Fd),
                                              New_Item  => Pool_Container_P.Element (Container => Self.Pool,
                                                                                Key => Integer (Element.Fd)));

                  end if;
               end ;

            end if;
         end;
      end loop;
      return Retval;
   end Check_Pool;

   function Has_Message (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => True, Send => False);
   end Has_Message;

   function Ready_To_Send (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => False, Send => True);
   end Ready_To_Send;

   function Ready_To_Send_Receive (Self : in Pool_T) return Pool_T is
   begin
      return Check_Pool (Self, Receive => True, Send => True);
   end Ready_To_Send_Receive;

   function Has_Socket (Self   : in Pool_T;
                        Socket : in Nanomsg.Socket.Socket_T) return Boolean is (Pool_Container_P.Contains (Self.Pool, Socket.Get_Fd));

end Nanomsg.Socket_Pools;

Fix undefined behaviour (GNAT GPL warning)


-----------------------------------------------------------------------
--  awa-commands -- AWA commands for server or admin tool
--  Copyright (C) 2019, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;
with AWA.Applications.Configs;
with Keystore.Passwords.Input;
with Keystore.Passwords.Files;
with Keystore.Passwords.Unsafe;
with Keystore.Passwords.Cmds;
package body AWA.Commands is

   use type Keystore.Passwords.Provider_Access;
   use type Keystore.Header_Slot_Count_Type;
   use type Keystore.Passwords.Keys.Key_Provider_Access;

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Commands");

   procedure Load_Configuration (Context : in out Context_Type) is
   begin
      begin
         Context.File_Config.Load_Properties (Context.Config_File.all);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read server configuration file '{0}'",
                       Context.Config_File.all);
      end;
      if Context.File_Config.Exists (GPG_CRYPT_CONFIG) then
         Context.GPG.Set_Encrypt_Command (Context.File_Config.Get (GPG_CRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_DECRYPT_CONFIG) then
         Context.GPG.Set_Decrypt_Command (Context.File_Config.Get (GPG_DECRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_LIST_CONFIG) then
         Context.GPG.Set_List_Key_Command (Context.File_Config.Get (GPG_LIST_CONFIG));
      end if;
      Context.Config.Randomize := not Context.Zero;
   end Load_Configuration;

   --  ------------------------------
   --  Returns True if a keystore is used by the configuration and must be unlocked.
   --  ------------------------------
   function Use_Keystore (Context : in Context_Type) return Boolean is
   begin
      if Context.Wallet_File'Length > 0 then
         return True;
      end if;

      return Context.File_Config.Exists ("keystore.path");
   end Use_Keystore;

   --  ------------------------------
   --  Open the keystore file using the password password.
   --  ------------------------------
   procedure Open_Keystore (Context    : in out Context_Type) is
   begin
      Setup_Password_Provider (Context);
      Setup_Key_Provider (Context);

      Context.Wallet.Open (Path      => Context.Get_Keystore_Path,
                           Data_Path => Context.Data_Path.all,
                           Config    => Context.Config,
                           Info      => Context.Info);

      if not Context.No_Password_Opt or else Context.Info.Header_Count = 0 then
         if Context.Key_Provider /= null then
            Context.Wallet.Set_Master_Key (Context.Key_Provider.all);
         end if;
         if Context.Provider = null then
            Context.Provider := Keystore.Passwords.Input.Create (-("Enter password: "), False);
         end if;

         Context.Wallet.Unlock (Context.Provider.all, Context.Slot);
      else
         Context.GPG.Load_Secrets (Context.Wallet);

         Context.Wallet.Set_Master_Key (Context.GPG);

         Context.Wallet.Unlock (Context.GPG, Context.Slot);
      end if;

      Keystore.Properties.Initialize (Context.Secure_Config, Context.Wallet'Unchecked_Access);
      AWA.Applications.Configs.Merge (Context.App_Config,
                                      Context.File_Config,
                                      Context.Secure_Config,
                                      "");
   end Open_Keystore;

   --  ------------------------------
   --  Configure the application by loading its configuration file and merging it with
   --  the keystore file if there is one.
   --  ------------------------------
   procedure Configure (Application : in out AWA.Applications.Application'Class;
                        Name        : in String;
                        Context     : in out Context_Type) is
      Path : constant String := AWA.Applications.Configs.Get_Config_Path (Name);
   begin
      begin
         Context.File_Config.Load_Properties (Path);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            null;
      end;

      if Context.Use_Keystore then
         Open_Keystore (Context);
      else
         Context.App_Config := Context.File_Config;
      end if;
      Application.Initialize (Context.App_Config, Context.Factory);
   end Configure;

   --  ------------------------------
   --  Initialize the commands.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Context.Command_Config,
                    Usage  => "[switchs] command [arguments]",
                    Help   => -("akt - tool to store and protect your sensitive data"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Version'Access,
                        Switch => "-V",
                        Long_Switch => "--version",
                        Help   => -("Print the version"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Verbose'Access,
                        Switch => "-v",
                        Long_Switch => "--verbose",
                        Help   => -("Verbose execution mode"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Debug'Access,
                        Switch => "-vv",
                        Long_Switch => "--debug",
                        Help   => -("Enable debug execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Dump'Access,
                        Switch => "-vvv",
                        Long_Switch => "--debug-dump",
                        Help   => -("Enable debug dump execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Zero'Access,
                        Switch => "-z",
                        Long_Switch => "--zero",
                        Help   => -("Erase and fill with zeros instead of random values"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Config_File'Access,
                        Switch => "-c:",
                        Long_Switch => "--config=",
                        Argument => "PATH",
                        Help   => -("Defines the path for configuration file"));
      GC.Initialize_Option_Scan (Stop_At_First_Non_Switch => True);

--      Driver.Set_Description (-("akt - tool to store and protect your sensitive data"));
--     Driver.Set_Usage (-("[-V] [-v] [-vv] [-vvv] [-c path] [-t count] [-z] " &
--                          "<command> [<args>]" & ASCII.LF &
--                          "where:" & ASCII.LF &
--                          "  -V           Print the tool version" & ASCII.LF &
--                          "  -v           Verbose execution mode" & ASCII.LF &
--                          "  -vv          Debug execution mode" & ASCII.LF &
--                          "  -vvv         Dump execution mode" & ASCII.LF &
--                          "  -c path      Defines the path for akt " &
--                          "global configuration" & ASCII.LF &
--                          "  -t count     Number of threads for the " &
--                          "encryption/decryption process" & ASCII.LF &
--                          "  -z           Erase and fill with zeros instead of random values"));
--      Driver.Add_Command ("help",
--                          -("print some help"),
--                          Help_Command'Access);
   end Initialize;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup_Command (Config  : in out GC.Command_Line_Configuration;
                            Context : in out Context_Type) is
   begin
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_File'Access,
                        Switch => "-k:",
                        Long_Switch => "--keystore=",
                        Argument => "PATH",
                        Help   => -("Defines the path for the keystore file"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Data_Path'Access,
                        Switch => "-d:",
                        Long_Switch => "--data-path=",
                        Argument => "PATH",
                        Help   => -("The directory which contains the keystore data blocks"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_File'Access,
                        Long_Switch => "--passfile=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passfd=",
                        Argument => "NUM",
                        Help   => -("Read the password from the pipe with"
                          & " the given file descriptor"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passsocket=",
                        Help   => -("The password is passed within the socket connection"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Env'Access,
                        Long_Switch => "--passenv=",
                        Argument => "NAME",
                        Help   => -("Read the environment variable that contains"
                        & " the password (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Switch => "-p:",
                        Long_Switch => "--password=",
                        Help   => -("The password is passed within the command line (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Askpass'Access,
                        Long_Switch => "--passask",
                        Help   => -("Run the ssh-askpass command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Command'Access,
                        Long_Switch => "--passcmd=",
                        Argument => "COMMAND",
                        Help   => -("Run the command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_Key_File'Access,
                        Long_Switch => "--wallet-key-file=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the wallet keys"));
   end Setup_Command;

   procedure Setup_Password_Provider (Context : in out Context_Type) is
   begin
      if Context.Password_Askpass then
         Context.Provider := Keystore.Passwords.Cmds.Create ("ssh-askpass");
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Password_File'Length > 0 then
         Context.Provider := Keystore.Passwords.Files.Create (Context.Password_File.all);
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Unsafe_Password'Length > 0 then
         Context.Provider := Keystore.Passwords.Unsafe.Create (Context.Unsafe_Password.all);
      else
         Context.No_Password_Opt := True;
      end if;
      Context.Key_Provider := Keystore.Passwords.Keys.Create (Keystore.DEFAULT_WALLET_KEY);
   end Setup_Password_Provider;

   procedure Setup_Key_Provider (Context : in out Context_Type) is
   begin
      if Context.Wallet_Key_File'Length > 0 then
         Context.Key_Provider := Keystore.Passwords.Files.Create (Context.Wallet_Key_File.all);
      end if;
   end Setup_Key_Provider;

   --  ------------------------------
   --  Get the keystore file path.
   --  ------------------------------
   function Get_Keystore_Path (Context : in out Context_Type) return String is
   begin
      if Context.Wallet_File'Length > 0 then
         Context.First_Arg := 1;
         return Context.Wallet_File.all;
      else
         raise Error with "No keystore path";
      end if;
   end Get_Keystore_Path;

   overriding
   procedure Finalize (Context : in out Context_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Keystore.Passwords.Provider'Class,
                                        Name   => Keystore.Passwords.Provider_Access);
   begin
      GC.Free (Context.Command_Config);
      Free (Context.Provider);
   end Finalize;

end AWA.Commands;

-----------------------------------------------------------------------
--  awa-commands -- AWA commands for server or admin tool
--  Copyright (C) 2019, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.IO_Exceptions;
with Ada.Command_Line;
with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;
with AWA.Applications.Configs;
with Keystore.Passwords.Input;
with Keystore.Passwords.Files;
with Keystore.Passwords.Unsafe;
with Keystore.Passwords.Cmds;
package body AWA.Commands is

   use type Keystore.Passwords.Provider_Access;
   use type Keystore.Header_Slot_Count_Type;
   use type Keystore.Passwords.Keys.Key_Provider_Access;

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Commands");

   procedure Load_Configuration (Context : in out Context_Type;
                                 Path    : in String) is
   begin
      begin
         Context.File_Config.Load_Properties (Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read server configuration file '{0}'",
                       Path);
      end;
      if Context.File_Config.Exists (GPG_CRYPT_CONFIG) then
         Context.GPG.Set_Encrypt_Command (Context.File_Config.Get (GPG_CRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_DECRYPT_CONFIG) then
         Context.GPG.Set_Decrypt_Command (Context.File_Config.Get (GPG_DECRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_LIST_CONFIG) then
         Context.GPG.Set_List_Key_Command (Context.File_Config.Get (GPG_LIST_CONFIG));
      end if;
      Context.Config.Randomize := not Context.Zero;
   end Load_Configuration;

   --  ------------------------------
   --  Returns True if a keystore is used by the configuration and must be unlocked.
   --  ------------------------------
   function Use_Keystore (Context : in Context_Type) return Boolean is
   begin
      if Context.Wallet_File'Length > 0 then
         return True;
      end if;

      return Context.File_Config.Exists ("keystore.path");
   end Use_Keystore;

   --  ------------------------------
   --  Open the keystore file using the password password.
   --  ------------------------------
   procedure Open_Keystore (Context    : in out Context_Type) is
   begin
      Setup_Password_Provider (Context);
      Setup_Key_Provider (Context);

      Context.Wallet.Open (Path      => Context.Get_Keystore_Path,
                           Data_Path => Context.Data_Path.all,
                           Config    => Context.Config,
                           Info      => Context.Info);

      if not Context.No_Password_Opt or else Context.Info.Header_Count = 0 then
         if Context.Key_Provider /= null then
            Context.Wallet.Set_Master_Key (Context.Key_Provider.all);
         end if;
         if Context.Provider = null then
            Context.Provider := Keystore.Passwords.Input.Create (-("Enter password: "), False);
         end if;

         Context.Wallet.Unlock (Context.Provider.all, Context.Slot);
      else
         Context.GPG.Load_Secrets (Context.Wallet);

         Context.Wallet.Set_Master_Key (Context.GPG);

         Context.Wallet.Unlock (Context.GPG, Context.Slot);
      end if;

      Keystore.Properties.Initialize (Context.Secure_Config,
                                      Context.Wallet'Unchecked_Access);
      AWA.Applications.Configs.Merge (Context.App_Config,
                                      Context.File_Config,
                                      Context.Secure_Config,
                                      "");
   end Open_Keystore;

   --  ------------------------------
   --  Configure the application by loading its configuration file and merging it with
   --  the keystore file if there is one.
   --  ------------------------------
   procedure Configure (Application : in out AWA.Applications.Application'Class;
                        Name        : in String;
                        Context     : in out Context_Type) is
      Path : constant String := AWA.Applications.Configs.Get_Config_Path (Name);
   begin
      begin
         Context.File_Config.Load_Properties (Path);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            null;
      end;

      if Context.Use_Keystore then
         Open_Keystore (Context);
      else
         Context.App_Config := Context.File_Config;
      end if;
      Application.Initialize (Context.App_Config, Context.Factory);
   end Configure;

   --  ------------------------------
   --  Initialize the commands.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Context.Command_Config,
                    Usage  => "[switchs] command [arguments]",
                    Help   => -("akt - tool to store and protect your sensitive data"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Version'Access,
                        Switch => "-V",
                        Long_Switch => "--version",
                        Help   => -("Print the version"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Verbose'Access,
                        Switch => "-v",
                        Long_Switch => "--verbose",
                        Help   => -("Verbose execution mode"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Debug'Access,
                        Switch => "-vv",
                        Long_Switch => "--debug",
                        Help   => -("Enable debug execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Dump'Access,
                        Switch => "-vvv",
                        Long_Switch => "--debug-dump",
                        Help   => -("Enable debug dump execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Zero'Access,
                        Switch => "-z",
                        Long_Switch => "--zero",
                        Help   => -("Erase and fill with zeros instead of random values"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Config_File'Access,
                        Switch => "-c:",
                        Long_Switch => "--config=",
                        Argument => "PATH",
                        Help   => -("Defines the path for configuration file"));
      GC.Initialize_Option_Scan (Stop_At_First_Non_Switch => True);

--      Driver.Set_Description (-("akt - tool to store and protect your sensitive data"));
--     Driver.Set_Usage (-("[-V] [-v] [-vv] [-vvv] [-c path] [-t count] [-z] " &
--                          "<command> [<args>]" & ASCII.LF &
--                          "where:" & ASCII.LF &
--                          "  -V           Print the tool version" & ASCII.LF &
--                          "  -v           Verbose execution mode" & ASCII.LF &
--                          "  -vv          Debug execution mode" & ASCII.LF &
--                          "  -vvv         Dump execution mode" & ASCII.LF &
--                          "  -c path      Defines the path for akt " &
--                          "global configuration" & ASCII.LF &
--                          "  -t count     Number of threads for the " &
--                          "encryption/decryption process" & ASCII.LF &
--                          "  -z           Erase and fill with zeros instead of random values"));
--      Driver.Add_Command ("help",
--                          -("print some help"),
--                          Help_Command'Access);
   end Initialize;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup_Command (Config  : in out GC.Command_Line_Configuration;
                            Context : in out Context_Type) is
   begin
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_File'Access,
                        Switch => "-k:",
                        Long_Switch => "--keystore=",
                        Argument => "PATH",
                        Help   => -("Defines the path for the keystore file"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Data_Path'Access,
                        Switch => "-d:",
                        Long_Switch => "--data-path=",
                        Argument => "PATH",
                        Help   => -("The directory which contains the keystore data blocks"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_File'Access,
                        Long_Switch => "--passfile=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passfd=",
                        Argument => "NUM",
                        Help   => -("Read the password from the pipe with"
                          & " the given file descriptor"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passsocket=",
                        Help   => -("The password is passed within the socket connection"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Env'Access,
                        Long_Switch => "--passenv=",
                        Argument => "NAME",
                        Help   => -("Read the environment variable that contains"
                        & " the password (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Switch => "-p:",
                        Long_Switch => "--password=",
                        Help   => -("The password is passed within the command line (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Askpass'Access,
                        Long_Switch => "--passask",
                        Help   => -("Run the ssh-askpass command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Command'Access,
                        Long_Switch => "--passcmd=",
                        Argument => "COMMAND",
                        Help   => -("Run the command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_Key_File'Access,
                        Long_Switch => "--wallet-key-file=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the wallet keys"));
   end Setup_Command;

   procedure Setup_Password_Provider (Context : in out Context_Type) is
   begin
      if Context.Password_Askpass then
         Context.Provider := Keystore.Passwords.Cmds.Create ("ssh-askpass");
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Password_File'Length > 0 then
         Context.Provider := Keystore.Passwords.Files.Create (Context.Password_File.all);
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Unsafe_Password'Length > 0 then
         Context.Provider := Keystore.Passwords.Unsafe.Create (Context.Unsafe_Password.all);
      else
         Context.No_Password_Opt := True;
      end if;
      Context.Key_Provider := Keystore.Passwords.Keys.Create (Keystore.DEFAULT_WALLET_KEY);
   end Setup_Password_Provider;

   procedure Setup_Key_Provider (Context : in out Context_Type) is
   begin
      if Context.Wallet_Key_File'Length > 0 then
         Context.Key_Provider := Keystore.Passwords.Files.Create (Context.Wallet_Key_File.all);
      end if;
   end Setup_Key_Provider;

   --  ------------------------------
   --  Get the keystore file path.
   --  ------------------------------
   function Get_Keystore_Path (Context : in out Context_Type) return String is
   begin
      if Context.Wallet_File'Length > 0 then
         Context.First_Arg := 1;
         return Context.Wallet_File.all;
      else
         raise Error with "No keystore path";
      end if;
   end Get_Keystore_Path;

   procedure Print (Context : in out Context_Type;
                    Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Ada.Exceptions.Reraise_Occurrence (Ex);

   exception
      when GNAT.Command_Line.Exit_From_Command_Line | GNAT.Command_Line.Invalid_Switch =>
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Bad_Password =>
         Log.Error (-("Invalid password to unlock the keystore file"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.No_Key_Slot =>
         Log.Error (-("There is no available key slot to add the password"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.No_Content =>
         Log.Error (-("No content for an item of type wallet"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Corrupted =>
         Log.Error (-("The keystore file is corrupted: invalid meta data content"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Invalid_Block =>
         Log.Error (-("The keystore file is corrupted: invalid data block headers or signature"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Invalid_Signature =>
         Log.Error (-("The keystore file is corrupted: invalid signature"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Invalid_Storage =>
         Log.Error (-("The keystore file is corrupted: invalid or missing storage file"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when Keystore.Invalid_Keystore =>
         Log.Error (-("The file is not a keystore"));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when AWA.Commands.Error | Util.Commands.Not_Found =>
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when E : Ada.IO_Exceptions.Name_Error =>
         Log.Error (-("Cannot access file: {0}"), Ada.Exceptions.Exception_Message (E));
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

      when E : others =>
         Log.Error (-("Some internal error occurred"), E);
         Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);

   end Print;

   overriding
   procedure Finalize (Context : in out Context_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Keystore.Passwords.Provider'Class,
                                        Name   => Keystore.Passwords.Provider_Access);
   begin
      GC.Free (Context.Command_Config);
      Free (Context.Provider);
   end Finalize;

end AWA.Commands;

Add Print procedure to report an error message depending on an exception


-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Ada.Text_IO; use Ada.Text_IO;
package body Util.Commands.Drivers is

   use Ada.Strings.Unbounded;

   --  The logger
   Logs : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create (Driver_Name);

   --  ------------------------------
   --  Get the description associated with the command.
   --  ------------------------------
   function Get_Description (Command : in Command_Type) return String is
   begin
      return To_String (Command.Description);
   end Get_Description;

   --  ------------------------------
   --  Get the name used to register the command.
   --  ------------------------------
   function Get_Name (Command : in Command_Type) return String is
   begin
      return To_String (Command.Name);
   end Get_Name;

   --  ------------------------------
   --  Write the command usage.
   --  ------------------------------
   procedure Usage (Command : in out Command_Type;
                    Name    : in String;
                    Context : in out Context_Type) is
      Config  : Config_Type;
   begin
      Command_Type'Class (Command).Setup (Config, Context);
      Config_Parser.Usage (Name, Config);
   end Usage;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   --  ------------------------------
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Command.Driver.Log (Level, Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      procedure Compute_Size (Position : in Command_Maps.Cursor);
      procedure Print (Position : in Command_Maps.Cursor);

      Column : Ada.Text_IO.Positive_Count := 1;

      procedure Compute_Size (Position : in Command_Maps.Cursor) is
         Name : constant String := Command_Maps.Key (Position);
      begin
         if Column < Name'Length then
            Column := Name'Length;
         end if;
      end Compute_Size;

      procedure Print (Position : in Command_Maps.Cursor) is
         Cmd  : constant Command_Access := Command_Maps.Element (Position);
         Name : constant String := Command_Maps.Key (Position);
      begin
         Put ("   ");
         Put (Name);
         if Length (Cmd.Description) > 0 then
            Set_Col (Column + 7);
            Put (To_String (Cmd.Description));
         end if;
         New_Line;
      end Print;

   begin
      Logs.Debug ("Execute command {0}", Name);

      if Args.Get_Count = 0 then
         Usage (Command.Driver.all, Args, Context);
         New_Line;
         Put ("Type '");
         Put (Args.Get_Command_Name);
         Put_Line (" help {command}' for help on a specific command.");
         New_Line;
         Put_Line ("Available subcommands:");

         Command.Driver.List.Iterate (Process => Compute_Size'Access);
         Command.Driver.List.Iterate (Process => Print'Access);
      else
         declare
            Cmd_Name   : constant String := Args.Get_Argument (1);
            Target_Cmd : constant Command_Access := Command.Driver.Find_Command (Cmd_Name);
         begin
            if Target_Cmd = null then
               Logs.Error ("Unknown command '{0}'", Cmd_Name);
               raise Not_Found;
            else
               Target_Cmd.Help (Cmd_Name, Context);
            end if;
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in out Help_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

   --  ------------------------------
   --  Report the command usage.
   --  ------------------------------
   procedure Usage (Driver  : in Driver_Type;
                    Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "") is
   begin
      Put_Line (To_String (Driver.Desc));
      New_Line;
      if Name'Length > 0 then
         declare
            Command : constant Command_Access := Driver.Find_Command (Name);
         begin
            if Command /= null then
               Command.Usage (Name, Context);
            else
               Put ("Invalid command");
            end if;
         end;
      else
         Put ("Usage: ");
         Put (Args.Get_Command_Name);
         Put (" ");
         Put_Line (To_String (Driver.Usage));
      end if;
   end Usage;

   --  ------------------------------
   --  Set the driver description printed in the usage.
   --  ------------------------------
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String) is
   begin
      Driver.Desc := Ada.Strings.Unbounded.To_Unbounded_String (Description);
   end Set_Description;

   --  ------------------------------
   --  Set the driver usage printed in the usage.
   --  ------------------------------
   procedure Set_Usage (Driver  : in out Driver_Type;
                        Usage   : in String) is
   begin
      Driver.Usage := Ada.Strings.Unbounded.To_Unbounded_String (Usage);
   end Set_Usage;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access) is
   begin
      Command.Name := To_Unbounded_String (Name);
      Command.Driver := Driver'Unchecked_Access;
      Driver.List.Include (Name, Command);
   end Add_Command;

   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Command     : in Command_Access) is
   begin
      Command.Name := To_Unbounded_String (Name);
      Command.Description := Ada.Strings.Unbounded.To_Unbounded_String (Description);
      Add_Command (Driver, Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Handler     : in Command_Handler) is
      Command : constant Command_Access
        := new Handler_Command_Type '(Driver      => Driver'Unchecked_Access,
                                      Description => To_Unbounded_String (Description),
                                      Name        => To_Unbounded_String (Name),
                                      Handler     => Handler);
   begin
      Driver.List.Include (Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Find the command having the given name.
   --  Returns null if the command was not found.
   --  ------------------------------
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access is
      Pos : constant Command_Maps.Cursor := Driver.List.Find (Name);
   begin
      if Command_Maps.Has_Element (Pos) then
         return Command_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Command;

   --  ------------------------------
   --  Execute the command registered under the given name.
   --  ------------------------------
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
      procedure Execute (Cmd_Args : in Argument_List'Class);

      Command : constant Command_Access := Driver.Find_Command (Name);

      procedure Execute (Cmd_Args : in Argument_List'Class) is
      begin
         Command.Execute (Name, Cmd_Args, Context);
      end Execute;

   begin
      if Command /= null then
         declare
            Config  : Config_Type;
         begin
            Command.Setup (Config, Context);
            Config_Parser.Execute (Config, Args, Execute'Access);
         end;
      else
         Logs.Error ("Unkown command '{0}'", Name);
         raise Not_Found;
      end if;
   end Execute;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  ------------------------------
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
      pragma Unreferenced (Driver);
   begin
      Logs.Print (Level, "{0}: {1}", Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command.Handler (Name, Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Handler_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

end Util.Commands.Drivers;

-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Ada.Text_IO; use Ada.Text_IO;
package body Util.Commands.Drivers is

   use Ada.Strings.Unbounded;

   --  The logger
   Logs : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create (Driver_Name);

   --  ------------------------------
   --  Get the description associated with the command.
   --  ------------------------------
   function Get_Description (Command : in Command_Type) return String is
   begin
      return To_String (Command.Description);
   end Get_Description;

   --  ------------------------------
   --  Get the name used to register the command.
   --  ------------------------------
   function Get_Name (Command : in Command_Type) return String is
   begin
      return To_String (Command.Name);
   end Get_Name;

   --  ------------------------------
   --  Write the command usage.
   --  ------------------------------
   procedure Usage (Command : in out Command_Type;
                    Name    : in String;
                    Context : in out Context_Type) is
      Config  : Config_Type;
   begin
      Command_Type'Class (Command).Setup (Config, Context);
      Config_Parser.Usage (Name, Config);
   end Usage;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   --  ------------------------------
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Command.Driver.Log (Level, Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      procedure Compute_Size (Position : in Command_Sets.Cursor);
      procedure Print (Position : in Command_Sets.Cursor);

      Column : Ada.Text_IO.Positive_Count := 1;

      procedure Compute_Size (Position : in Command_Sets.Cursor) is
         Cmd  : constant Command_Access := Command_Sets.Element (Position);
         Len  : constant Natural := Length (Cmd.Name);
      begin
         if Natural (Column) < Len then
            Column := Ada.Text_IO.Positive_Count (Len);
         end if;
      end Compute_Size;

      procedure Print (Position : in Command_Sets.Cursor) is
         Cmd  : constant Command_Access := Command_Sets.Element (Position);
      begin
         Put ("   ");
         Put (To_String (Cmd.Name));
         if Length (Cmd.Description) > 0 then
            Set_Col (Column + 7);
            Put (To_String (Cmd.Description));
         end if;
         New_Line;
      end Print;

   begin
      Logs.Debug ("Execute command {0}", Name);

      if Args.Get_Count = 0 then
         Usage (Command.Driver.all, Args, Context);
         New_Line;
         Put ("Type '");
         Put (Args.Get_Command_Name);
         Put_Line (" help {command}' for help on a specific command.");
         New_Line;
         Put_Line ("Available subcommands:");

         Command.Driver.List.Iterate (Process => Compute_Size'Access);
         Command.Driver.List.Iterate (Process => Print'Access);
      else
         declare
            Cmd_Name   : constant String := Args.Get_Argument (1);
            Target_Cmd : constant Command_Access := Command.Driver.Find_Command (Cmd_Name);
         begin
            if Target_Cmd = null then
               Logs.Error ("Unknown command '{0}'", Cmd_Name);
               raise Not_Found;
            else
               Target_Cmd.Help (Cmd_Name, Context);
            end if;
         end;
      end if;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in out Help_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

   --  ------------------------------
   --  Report the command usage.
   --  ------------------------------
   procedure Usage (Driver  : in Driver_Type;
                    Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "") is
   begin
      Put_Line (To_String (Driver.Desc));
      New_Line;
      if Name'Length > 0 then
         declare
            Command : constant Command_Access := Driver.Find_Command (Name);
         begin
            if Command /= null then
               Command.Usage (Name, Context);
            else
               Put ("Invalid command");
            end if;
         end;
      else
         Put ("Usage: ");
         Put (Args.Get_Command_Name);
         Put (" ");
         Put_Line (To_String (Driver.Usage));
      end if;
   end Usage;

   --  ------------------------------
   --  Set the driver description printed in the usage.
   --  ------------------------------
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String) is
   begin
      Driver.Desc := Ada.Strings.Unbounded.To_Unbounded_String (Description);
   end Set_Description;

   --  ------------------------------
   --  Set the driver usage printed in the usage.
   --  ------------------------------
   procedure Set_Usage (Driver  : in out Driver_Type;
                        Usage   : in String) is
   begin
      Driver.Usage := Ada.Strings.Unbounded.To_Unbounded_String (Usage);
   end Set_Usage;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access) is
   begin
      Command.Name := To_Unbounded_String (Name);
      Command.Driver := Driver'Unchecked_Access;
      Driver.List.Include (Command);
   end Add_Command;

   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Command     : in Command_Access) is
   begin
      Command.Name := To_Unbounded_String (Name);
      Command.Description := To_Unbounded_String (Description);
      Add_Command (Driver, Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Handler     : in Command_Handler) is
      Command : constant Command_Access
        := new Handler_Command_Type '(Driver      => Driver'Unchecked_Access,
                                      Description => To_Unbounded_String (Description),
                                      Name        => To_Unbounded_String (Name),
                                      Handler     => Handler);
   begin
      Driver.List.Include (Command);
   end Add_Command;

   --  ------------------------------
   --  Find the command having the given name.
   --  Returns null if the command was not found.
   --  ------------------------------
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access is
      Cmd : aliased Help_Command_Type;
      Pos : Command_Sets.Cursor;
   begin
      Cmd.Name := To_Unbounded_String (Name);
      Pos := Driver.List.Find (Cmd'Unchecked_Access);
      if Command_Sets.Has_Element (Pos) then
         return Command_Sets.Element (Pos);
      else
         return null;
      end if;
   end Find_Command;

   --  ------------------------------
   --  Execute the command registered under the given name.
   --  ------------------------------
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
      procedure Execute (Cmd_Args : in Argument_List'Class);

      Command : constant Command_Access := Driver.Find_Command (Name);

      procedure Execute (Cmd_Args : in Argument_List'Class) is
      begin
         Command.Execute (Name, Cmd_Args, Context);
      end Execute;

   begin
      if Command /= null then
         declare
            Config  : Config_Type;
         begin
            Command.Setup (Config, Context);
            Config_Parser.Execute (Config, Args, Execute'Access);
         end;
      else
         Logs.Error ("Unkown command '{0}'", Name);
         raise Not_Found;
      end if;
   end Execute;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  ------------------------------
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
      pragma Unreferenced (Driver);
   begin
      Logs.Print (Level, "{0}: {1}", Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command.Handler (Name, Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Handler_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

end Util.Commands.Drivers;

Change the implementation to use an Ordered_Set