-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011 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.
-----------------------------------------------------------------------

package body ASF.Beans.Mappers is

   Empty : constant Util.Beans.Objects.Object := Util.Beans.Objects.To_Object (String '(""));

   Empty_Params : ASF.Beans.Parameter_Bean_Ref.Ref;

   --  ------------------------------
   --  Set the field identified by Field with the Value.
   --  ------------------------------
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            MBean.Name := Value;

         when FIELD_CLASS =>
            MBean.Class := Value;

         when FIELD_SCOPE =>
            declare
               Scope : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Scope = "request" then
                  MBean.Scope := REQUEST_SCOPE;
               elsif Scope = "session" then
                  MBean.Scope := SESSION_SCOPE;
               elsif Scope = "application" then
                  MBean.Scope := APPLICATION_SCOPE;
               else
                  raise Util.Serialize.Mappers.Field_Error with "Invalid scope: " & Scope;
               end if;
            end;

         when FIELD_PROPERTY_NAME =>
            MBean.Prop_Name := Value;

         when FIELD_PROPERTY_VALUE =>
            MBean.Prop_Value := Value;

         when FIELD_PROPERTY_CLASS =>
            null;

         when FIELD_PROPERTY =>
            --  Create the parameter list only the first time a property is seen.
            if MBean.Params.Is_Null then
               MBean.Params := ASF.Beans.Parameter_Bean_Ref.Create (new ASF.Beans.Parameter_Bean);
            end if;

            --  Add the parameter.  The property value is parsed as an EL expression.
            EL.Beans.Add_Parameter (MBean.Params.Value.all.Params,
                                    Util.Beans.Objects.To_String (MBean.Prop_Name),
                                    Util.Beans.Objects.To_String (MBean.Prop_Value),
                                    MBean.Context.all);
            MBean.Prop_Name  := Empty;
            MBean.Prop_Value := Empty;

         when FIELD_MANAGED_BEAN =>
            declare
               Name  : constant String := Util.Beans.Objects.To_String (MBean.Name);
               Class : constant String := Util.Beans.Objects.To_String (MBean.Class);
            begin
               Register (Factory => MBean.Factory.all,
                         Name    => Name,
                         Class   => Class,
                         Params  => MBean.Params,
                         Scope   => MBean.Scope);
            end;
            MBean.Name  := Empty;
            MBean.Class := Empty;
            MBean.Scope := REQUEST_SCOPE;
            MBean.Params := Empty_Params;

      end case;
   end Set_Member;

   MBean_Mapping : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the managed bean definitions.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", MBean_Mapping'Access);
      Reader.Add_Mapping ("module", MBean_Mapping'Access);
      Reader.Add_Mapping ("web-app", MBean_Mapping'Access);
      Config.Factory := Factory;
      Config.Context := Context;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   --  <managed-bean> mapping
   MBean_Mapping.Add_Mapping ("managed-bean", FIELD_MANAGED_BEAN);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-name", FIELD_NAME);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-class", FIELD_CLASS);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-scope", FIELD_SCOPE);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/property-name", FIELD_PROPERTY_NAME);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/value", FIELD_PROPERTY_VALUE);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/property-class",
                              FIELD_PROPERTY_CLASS);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property", FIELD_PROPERTY);
end ASF.Beans.Mappers;

-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011, 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.
-----------------------------------------------------------------------

package body ASF.Beans.Mappers is

   Empty : constant Util.Beans.Objects.Object := Util.Beans.Objects.To_Object (String '(""));

   Empty_Params : ASF.Beans.Parameter_Bean_Ref.Ref;

   --  ------------------------------
   --  Set the field identified by Field with the Value.
   --  ------------------------------
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            MBean.Name := Value;

         when FIELD_CLASS =>
            MBean.Class := Value;

         when FIELD_SCOPE =>
            declare
               Scope : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Scope = "request" then
                  MBean.Scope := REQUEST_SCOPE;
               elsif Scope = "session" then
                  MBean.Scope := SESSION_SCOPE;
               elsif Scope = "application" then
                  MBean.Scope := APPLICATION_SCOPE;
               else
                  raise Util.Serialize.Mappers.Field_Error with "Invalid scope: " & Scope;
               end if;
            end;

         when FIELD_PROPERTY_NAME =>
            MBean.Prop_Name := Value;

         when FIELD_PROPERTY_VALUE =>
            MBean.Prop_Value := Value;

         when FIELD_PROPERTY_CLASS =>
            null;

         when FIELD_PROPERTY =>
            --  Create the parameter list only the first time a property is seen.
            if MBean.Params.Is_Null then
               MBean.Params := ASF.Beans.Parameter_Bean_Ref.Create (new ASF.Beans.Parameter_Bean);
            end if;

            --  Add the parameter.  The property value is parsed as an EL expression.
            EL.Beans.Add_Parameter (MBean.Params.Value.all.Params,
                                    Util.Beans.Objects.To_String (MBean.Prop_Name),
                                    Util.Beans.Objects.To_String (MBean.Prop_Value),
                                    MBean.Context.all);
            MBean.Prop_Name  := Empty;
            MBean.Prop_Value := Empty;

         when FIELD_MANAGED_BEAN =>
            declare
               Name  : constant String := Util.Beans.Objects.To_String (MBean.Name);
               Class : constant String := Util.Beans.Objects.To_String (MBean.Class);
            begin
               Register (Factory => MBean.Factory.all,
                         Name    => Name,
                         Class   => Class,
                         Params  => MBean.Params,
                         Scope   => MBean.Scope);
            end;
            MBean.Name  := Empty;
            MBean.Class := Empty;
            MBean.Scope := REQUEST_SCOPE;
            MBean.Params := Empty_Params;

      end case;
   end Set_Member;

   MBean_Mapping : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the managed bean definitions.
   --  ------------------------------
   package body Reader_Config is
   begin
      Mapper.Add_Mapping ("faces-config", MBean_Mapping'Access);
      Mapper.Add_Mapping ("module", MBean_Mapping'Access);
      Mapper.Add_Mapping ("web-app", MBean_Mapping'Access);
      Config.Factory := Factory;
      Config.Context := Context;
      Config_Mapper.Set_Context (Mapper, Config'Unchecked_Access);
   end Reader_Config;

begin
   --  <managed-bean> mapping
   MBean_Mapping.Add_Mapping ("managed-bean", FIELD_MANAGED_BEAN);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-name", FIELD_NAME);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-class", FIELD_CLASS);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-bean-scope", FIELD_SCOPE);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/property-name", FIELD_PROPERTY_NAME);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/value", FIELD_PROPERTY_VALUE);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property/property-class",
                              FIELD_PROPERTY_CLASS);
   MBean_Mapping.Add_Mapping ("managed-bean/managed-property", FIELD_PROPERTY);
end ASF.Beans.Mappers;

Update the Reader_Config to use the new parser/mapper interface


-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  Copyright (C) 2014 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 System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with MAT.Types;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer := To_Pointer (Buffer.Current
                                           + Storage_Offset (1));
      Low : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size <= 1 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size < 4 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 4;
      Buffer.Current := Buffer.Current + Storage_Offset (4);
      if Buffer.Current >= Buffer.Last then
         Buffer.Current := Buffer.Start;
      end if;
      return P.all;
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : MAT.Types.Uint64 := MAT.Types.Uint64 (Get_Uint32 (Buffer));
   begin
      return Val + MAT.Types.Uint64 (Get_Uint32 (Buffer)) * 2**32;
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            pragma Assert (False, "Invalid attribute type ");
            return 0;
      end case;
   end Get_Target_Value;

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  Copyright (C) 2014 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 System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with MAT.Types;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer := To_Pointer (Buffer.Current
                                           + Storage_Offset (1));
      Low : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size <= 1 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size < 4 then
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 4;
      Buffer.Current := Buffer.Current + Storage_Offset (4);
      if Buffer.Current >= Buffer.Last then
         Buffer.Current := Buffer.Start;
      end if;
      return P.all;
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : MAT.Types.Uint64 := MAT.Types.Uint64 (Get_Uint32 (Buffer));
   begin
      return Val + MAT.Types.Uint64 (Get_Uint32 (Buffer)) * 2**32;
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            pragma Assert (False, "Invalid attribute type ");
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Buffer_Ptr) return String is
      Len    : constant MAT.Types.Uint8 := Get_Uint8 (Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer));
      end loop;
      return Result;
   end Get_String;

end MAT.Readers.Marshaller;

Implement the Get_String operation

Implement the Get_String operation


-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013 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;
with ADO.Queries.Loaders;
package body ADO.Drivers is

   use Util.Log;

   Log : constant Loggers.Logger := 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);

      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Global_Config.Get ("ado.queries.paths", ".;db"),
                                      Global_Config.Get ("ado.queries.load", "false") = "true");
      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;

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

end ADO.Drivers;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 2013 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;

with ADO.Queries.Loaders;
package body ADO.Drivers is

   use Util.Log;

   Log : constant Loggers.Logger := 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);

      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Global_Config.Get ("ado.queries.paths", ".;db"),
                                      Global_Config.Get ("ado.queries.load", "false") = "true");

      --  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;

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

end ADO.Drivers;

Add some comments

Add some comments


--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Finalization;

with Ahven;
with Ahven.Listeners;
with Ahven.SList;
with Ahven.AStrings;

pragma Elaborate_All (Ahven);
pragma Elaborate_All (Ahven.SList);

package Ahven.Framework is

   Three_Hours : constant := 10800.0;

   subtype Test_Duration is Duration range 0.0 .. Three_Hours;

   type Test_Count_Type is new Natural;
   -- Type for the test count. This effectively
   -- limits the amount tests to whatever Natural is.
   --
   -- Although, in practice when adding tests the limit
   -- is not checked.

   type Test is abstract new Ada.Finalization.Controlled with null record;
   -- A type, which provides the base for Test_Case and
   -- Test_Suite types.

   type Test_Class_Access is access all Test'Class;

   procedure Set_Up (T : in out Test);
   -- Set_Up is called before executing the test procedure.
   --
   -- By default, the procedure does nothing, but derived
   -- types can overwrite this method and add their own
   -- customisations.
   --
   -- One should not call this explicitly by herself.
   -- The framework calls it when necessary.

   procedure Tear_Down (T : in out Test);
   -- Tear_Down is called after the test procedure is executed.
   --
   -- By default, the procedure does nothing, but derived
   -- types can overwrite this method and add their own
   -- customisations.
   --
   -- One should not call this explicitly by herself.
   -- The framework calls it when necessary.

   function Get_Name (T : Test) return String is abstract;
   -- Return the name of the test.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   procedure Run (T         : in out Test;
                  Listener  : in out Listeners.Result_Listener'Class);
   -- Run the test and place the test result to Result.
   --
   -- Calls Run (T, Listener, Timeout) with Timeout value 0.0.

   procedure Run (T         : in out Test;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration)
     is abstract;
   -- Run the test and place the test result to Result.
   -- Timeout specifies the maximum runtime for a single test.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   procedure Run (T         : in out Test;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class);
   -- Run the test and place the test result to Result.
   --
   -- Calls Run (T, Test_Name, Listener, Timeout) with Timeout value 0.0.

   procedure Run (T         : in out Test;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration)
     is abstract;
   -- Run the test with given name and place the test result to Result.
   -- Timeout specifies the maximum runtime for a single test.
   -- Notice: If multiple tests have same name this might call all of
   -- them.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   function Test_Count (T : Test) return Test_Count_Type is abstract;
   -- Return the amount of tests (test routines) which will be executed when
   -- the Run (T) procedure is called.

   function Test_Count (T : Test; Test_Name : String)
     return Test_Count_Type is abstract;
   -- Return the amount of tests (test routines) which will be executed when
   -- the Run (T, Test_Name) procedure is called.

   procedure Execute (T        : in out Test'Class;
                      Listener : in out Listeners.Result_Listener'Class;
                      Timeout  :        Test_Duration);
   -- Call Test class' Run method and place the test outcome to Result.
   -- The procedure calls Start_Test of every listener before calling
   -- the Run procedure and End_Test after calling the Run procedure.
   --
   -- This procedure is meant to be called from Runner package(s).
   -- There should be no need for other to use this.

   procedure Execute (T         : in out Test'Class;
                      Test_Name :        String;
                      Listener  : in out Listeners.Result_Listener'Class;
                      Timeout   :        Test_Duration);
   -- Same as Execute above, but call the Run procedure which
   -- takes Test_Name parameter.

   type Test_Case is abstract new Test with private;
   -- The base type for other test cases.

   function Get_Name (T : Test_Case) return String;
   -- Return the name of the test case.

   procedure Run (T        : in out Test_Case;
                  Listener : in out Listeners.Result_Listener'Class;
                  Timeout  :        Test_Duration);
   -- Run Test_Case's test routines.

   procedure Run (T         : in out Test_Case;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run Test_Case's test routine which matches to the Name.

   function Test_Count (T : Test_Case) return Test_Count_Type;
   -- Implementation of Test_Count (T : Test).

   function Test_Count (T : Test_Case; Test_Name : String)
     return Test_Count_Type;
   -- Implementation of Test_Count (T : Test, Test_Name : String).

   procedure Finalize (T : in out Test_Case);
   -- Finalize procedure of the Test_Case.

   procedure Set_Name (T : in out Test_Case; Name : String);
   -- Set Test_Case's name.
   --
   -- If longer than 160 characters, the name is truncated
   -- to 160 characters.

   type Object_Test_Routine_Access is
     access procedure (T : in out Test_Case'Class);
   -- A pointer to a test routine which takes Test_Case'Class object
   -- as an argument.
   --
   -- For this kind of test routines, the framework will
   -- call Set_Up and Tear_Down routines before and after
   -- test routine execution.

   type Simple_Test_Routine_Access is access procedure;
   -- A pointer to a test routine which does not take arguments.

   procedure Add_Test_Routine (T       : in out Test_Case'Class;
                               Routine :        Object_Test_Routine_Access;
                               Name    :        String);
   -- Register a test routine to the Test_Case object.
   --
   -- The routine must have signature
   --  "procedure R (T : in out Test_Case'Class)".

   procedure Add_Test_Routine (T       : in out Test_Case'Class;
                               Routine :        Simple_Test_Routine_Access;
                               Name    :        String);
   -- Register a simple test routine to the Test_Case.
   --
   -- The routine must have signature
   --  "procedure R".

   type Test_Suite is new Test with private;
   -- A collection of Tests.
   --
   -- You can either fill a Test_Suite object with Test_Case objects
   -- or nest multiple Test_Suite objects. You can even mix
   -- Test_Case and Test_Suite objects, if necessary.

   type Test_Suite_Access is access all Test_Suite;

   function Create_Suite (Suite_Name : String)
     return Test_Suite_Access;
   -- Create a new Test_Suite.
   -- Caller must free the returned Test_Suite using Release_Suite.

   function Create_Suite (Suite_Name : String)
     return Test_Suite;
   -- Create a new Test_Suite. The suite and its children are
   -- released automatically.

   procedure Add_Test (Suite : in out Test_Suite; T : Test_Class_Access);
   -- Add a Test to the suite. The suite frees the Test automatically
   -- when it is no longer needed.

   procedure Add_Test (Suite : in out Test_Suite; T : Test_Suite_Access);
   -- Add a Test suite to the suite. The suite frees the Test automatically
   -- when it is no longer needed.
   --
   -- This is a helper function, which internally calls
   -- Add_Test (Suite : in out Test_Suite; T : Test_Class_Access).

   procedure Add_Static_Test
     (Suite : in out Test_Suite; T : Test'Class);
   -- Add a Test to the suite. This procedure is meant for statically
   -- allocated Test_Case objects.
   --
   -- Please note, that a copy of the Test'Class object is saved to
   -- the suite. Original test object is not modified and changes
   -- made to it after adding the test are not propagated to
   -- the added object.

   function Get_Name (T : Test_Suite) return String;
   -- Return the name of Test_Suite.

   procedure Run (T      : in out Test_Suite;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run Test_Suite's Test_Cases.

   procedure Run (T         : in out Test_Suite;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run test suite's child which matches to the given name.

   function Test_Count (T : Test_Suite) return Test_Count_Type;
   -- Implementation of Test_Count (T : Test).

   function Test_Count (T : Test_Suite; Test_Name : String)
     return Test_Count_Type;
   -- Implementation of Test_Count (T : Test, Test_Name : String).

   procedure Adjust (T : in out Test_Suite);
   -- Adjust procedure of Test_Suite.
   -- Handles the copying of the structure properly

   procedure Finalize (T : in out Test_Suite);
   -- Finalize procedure of Test_Suite. Frees all added Tests.

   procedure Release_Suite (T : Test_Suite_Access);
   -- Release the memory of Test_Suite.
   -- All added tests are released automatically.

private
   type Command_Object_Enum is (SIMPLE, OBJECT);

   type Test_Command (Command_Kind : Command_Object_Enum := SIMPLE) is record
      Name : AStrings.Bounded_String;
      case Command_Kind is
         when SIMPLE =>
            Simple_Routine : Simple_Test_Routine_Access;
         when OBJECT =>
            Object_Routine : Object_Test_Routine_Access;
      end case;
   end record;
   -- Name attribute tells the name of the test routine.

   procedure Run (Command : Test_Command; T : in out Test_Case'Class);
   -- Run the specified command.
   -- Calls Set_Up and Tear_Down if necessary.

   package Test_Command_List is
     new Ahven.SList (Element_Type => Test_Command);

   type Test_Case is abstract new Test with record
      Routines : Test_Command_List.List  := Test_Command_List.Empty_List;
      Name     : AStrings.Bounded_String := AStrings.Null_Bounded_String;
   end record;
   -- Our test case type. It holds a list of test routines
   -- (test command objects) and the name of the test case.

   procedure Run_Command (Command  :        Test_Command;
                          Info     :        Listeners.Context;
                          Timeout  :        Test_Duration;
                          Listener : in out Listeners.Result_Listener'Class;
                          T        : in out Test_Case'Class);
   -- Handle dispatching to the right Run (Command : Test_Command)
   -- procedure and record test routine result to the Result object.
   --
   -- Timeout parameter defines the longest time the test is allowed
   -- to run. Value 0.0 means infinite time.

   type Test_Class_Wrapper is record
      Ptr : Test_Class_Access;
   end record;

   package Test_List is
     new Ahven.SList (Element_Type => Test_Class_Wrapper);

   package Indefinite_Test_List is
      type List is new Ada.Finalization.Controlled with private;

      Empty_List : constant List;

      procedure Append (Target : in out List; Node_Data : Test'Class);
      -- Append an element at the end of the list.

      procedure Clear (Target : in out List);
      -- Remove all elements from the list.

      generic
         with procedure Action (T : in out Test'Class) is <>;
      procedure For_Each (Target : List);
      -- A generic procedure for walk through every item
      -- in the list and call Action procedure for them.

   private
      type Node;
      type Node_Access is access Node;

      procedure Remove (Ptr : Node_Access);
      -- A procedure to release memory pointed by Ptr.

      type Node is record
         Next : Node_Access       := null;
         Data : Test_Class_Access := null;
      end record;

      type List is new Ada.Finalization.Controlled with record
         First : Node_Access := null;
         Last  : Node_Access := null;
      end record;

      procedure Initialize (Target : in out List);
      procedure Finalize   (Target : in out List);
      procedure Adjust     (Target : in out List);

      Empty_List : constant List :=
        (Ada.Finalization.Controlled with First => null,
                                          Last  => null);
   end Indefinite_Test_List;

   type Test_Suite is new Test with record
      Suite_Name : AStrings.Bounded_String := AStrings.Null_Bounded_String;
      Test_Cases : Test_List.List := Test_List.Empty_List;
      Static_Test_Cases : Indefinite_Test_List.List :=
        Indefinite_Test_List.Empty_List;
   end record;
   -- A suite type which holds a list of test cases and the name
   -- of the suite.

end Ahven.Framework;

--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Finalization;

with Ahven;
with Ahven.Listeners;
with Ahven.SList;
with Ahven.AStrings;

pragma Elaborate_All (Ahven);
pragma Elaborate_All (Ahven.SList);

package Ahven.Framework is

   Three_Hours : constant := 10800.0;

   subtype Test_Duration is Duration range 0.0 .. Three_Hours;

   type Test_Count_Type is new Natural;
   -- Type for the test count. This effectively
   -- limits the amount tests to whatever Natural is.
   --
   -- Although, in practice when adding tests the limit
   -- is not checked.

   type Test is abstract new Ada.Finalization.Controlled with null record;
   -- A type, which provides the base for Test_Case and
   -- Test_Suite types.

   type Test_Class_Access is access all Test'Class;

   procedure Set_Up (T : in out Test);
   -- Set_Up is called before executing the test procedure.
   --
   -- By default, the procedure does nothing, but derived
   -- types can overwrite this method and add their own
   -- customisations.
   --
   -- One should not call this explicitly by herself.
   -- The framework calls it when necessary.

   procedure Tear_Down (T : in out Test);
   -- Tear_Down is called after the test procedure is executed.
   --
   -- By default, the procedure does nothing, but derived
   -- types can overwrite this method and add their own
   -- customisations.
   --
   -- One should not call this explicitly by herself.
   -- The framework calls it when necessary.

   function Get_Name (T : Test) return String is abstract;
   -- Return the name of the test.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   procedure Run (T         : in out Test;
                  Listener  : in out Listeners.Result_Listener'Class);
   -- Run the test and place the test result to Result.
   --
   -- Calls Run (T, Listener, Timeout) with Timeout value 0.0.

   procedure Run (T         : in out Test;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration)
     is abstract;
   -- Run the test and place the test result to Result.
   -- Timeout specifies the maximum runtime for a single test.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   procedure Run (T         : in out Test;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class);
   -- Run the test and place the test result to Result.
   --
   -- Calls Run (T, Test_Name, Listener, Timeout) with Timeout value 0.0.

   procedure Run (T         : in out Test;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration)
     is abstract;
   -- Run the test with given name and place the test result to Result.
   -- Timeout specifies the maximum runtime for a single test.
   -- Notice: If multiple tests have same name this might call all of
   -- them.
   --
   -- Types derived from the Test type are required to overwrite
   -- this procedure.

   function Test_Count (T : Test) return Test_Count_Type is abstract;
   -- Return the amount of tests (test routines) which will be executed when
   -- the Run (T) procedure is called.

   function Test_Count (T : Test; Test_Name : String)
     return Test_Count_Type is abstract;
   -- Return the amount of tests (test routines) which will be executed when
   -- the Run (T, Test_Name) procedure is called.

   procedure Execute (T        : in out Test'Class;
                      Listener : in out Listeners.Result_Listener'Class;
                      Timeout  :        Test_Duration);
   -- Call Test class' Run method and place the test outcome to Result.
   -- The procedure calls Start_Test of every listener before calling
   -- the Run procedure and End_Test after calling the Run procedure.
   --
   -- This procedure is meant to be called from Runner package(s).
   -- There should be no need for other to use this.

   procedure Execute (T         : in out Test'Class;
                      Test_Name :        String;
                      Listener  : in out Listeners.Result_Listener'Class;
                      Timeout   :        Test_Duration);
   -- Same as Execute above, but call the Run procedure which
   -- takes Test_Name parameter.

   type Test_Case is abstract new Test with private;
   -- The base type for other test cases.

   function Get_Name (T : Test_Case) return String;
   -- Return the name of the test case.

   procedure Run (T        : in out Test_Case;
                  Listener : in out Listeners.Result_Listener'Class;
                  Timeout  :        Test_Duration);
   -- Run Test_Case's test routines.

   procedure Run (T         : in out Test_Case;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run Test_Case's test routine which matches to the Name.

   function Test_Count (T : Test_Case) return Test_Count_Type;
   -- Implementation of Test_Count (T : Test).

   function Test_Count (T : Test_Case; Test_Name : String)
     return Test_Count_Type;
   -- Implementation of Test_Count (T : Test, Test_Name : String).

   procedure Finalize (T : in out Test_Case);
   -- Finalize procedure of the Test_Case.

   procedure Set_Name (T : in out Test_Case; Name : String);
   -- Set Test_Case's name.
   --
   -- If longer than 160 characters, the name is truncated
   -- to 160 characters.

   type Object_Test_Routine_Access is
     access procedure (T : in out Test_Case'Class);
   -- A pointer to a test routine which takes Test_Case'Class object
   -- as an argument.
   --
   -- For this kind of test routines, the framework will
   -- call Set_Up and Tear_Down routines before and after
   -- test routine execution.

   type Simple_Test_Routine_Access is access procedure;
   -- A pointer to a test routine which does not take arguments.

   procedure Add_Test_Routine (T       : in out Test_Case'Class;
                               Routine :        Object_Test_Routine_Access;
                               Name    :        String);
   -- Register a test routine to the Test_Case object.
   --
   -- The routine must have signature
   --  "procedure R (T : in out Test_Case'Class)".

   procedure Add_Test_Routine (T       : in out Test_Case'Class;
                               Routine :        Simple_Test_Routine_Access;
                               Name    :        String);
   -- Register a simple test routine to the Test_Case.
   --
   -- The routine must have signature
   --  "procedure R".

   type Test_Suite is new Test with private;
   -- A collection of Tests.
   --
   -- You can either fill a Test_Suite object with Test_Case objects
   -- or nest multiple Test_Suite objects. You can even mix
   -- Test_Case and Test_Suite objects, if necessary.

   type Test_Suite_Access is access all Test_Suite;

   function Create_Suite (Suite_Name : String)
     return Test_Suite_Access;
   -- Create a new Test_Suite.
   -- Caller must free the returned Test_Suite using Release_Suite.

   function Create_Suite (Suite_Name : String)
     return Test_Suite;
   -- Create a new Test_Suite. The suite and its children are
   -- released automatically.

   procedure Add_Test (Suite : in out Test_Suite; T : Test_Class_Access);
   -- Add a Test to the suite. The suite frees the Test automatically
   -- when it is no longer needed.

   procedure Add_Test (Suite : in out Test_Suite; T : Test_Suite_Access);
   -- Add a Test suite to the suite. The suite frees the Test automatically
   -- when it is no longer needed.
   --
   -- This is a helper function, which internally calls
   -- Add_Test (Suite : in out Test_Suite; T : Test_Class_Access).

   procedure Add_Static_Test
     (Suite : in out Test_Suite; T : Test'Class);
   -- Add a Test to the suite. This procedure is meant for statically
   -- allocated Test_Case objects.
   --
   -- Please note, that a copy of the Test'Class object is saved to
   -- the suite. Original test object is not modified and changes
   -- made to it after adding the test are not propagated to
   -- the added object.

   function Get_Name (T : Test_Suite) return String;
   -- Return the name of Test_Suite.

   procedure Run (T      : in out Test_Suite;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run Test_Suite's Test_Cases.

   procedure Run (T         : in out Test_Suite;
                  Test_Name :        String;
                  Listener  : in out Listeners.Result_Listener'Class;
                  Timeout   :        Test_Duration);
   -- Run test suite's child which matches to the given name.

   function Test_Count (T : Test_Suite) return Test_Count_Type;
   -- Implementation of Test_Count (T : Test).

   function Test_Count (T : Test_Suite; Test_Name : String)
     return Test_Count_Type;
   -- Implementation of Test_Count (T : Test, Test_Name : String).

   procedure Adjust (T : in out Test_Suite);
   -- Adjust procedure of Test_Suite.
   -- Handles the copying of the structure properly

   procedure Finalize (T : in out Test_Suite);
   -- Finalize procedure of Test_Suite. Frees all added Tests.

   procedure Release_Suite (T : Test_Suite_Access);
   -- Release the memory of Test_Suite.
   -- All added tests are released automatically.

   procedure Set_Logging (Flag : in Boolean);
   -- Enable or disable traces before/after test execution.

private
   type Command_Object_Enum is (SIMPLE, OBJECT);

   type Test_Command (Command_Kind : Command_Object_Enum := SIMPLE) is record
      Name : AStrings.Bounded_String;
      case Command_Kind is
         when SIMPLE =>
            Simple_Routine : Simple_Test_Routine_Access;
         when OBJECT =>
            Object_Routine : Object_Test_Routine_Access;
      end case;
   end record;
   -- Name attribute tells the name of the test routine.

   procedure Run (Command : Test_Command; T : in out Test_Case'Class);
   -- Run the specified command.
   -- Calls Set_Up and Tear_Down if necessary.

   package Test_Command_List is
     new Ahven.SList (Element_Type => Test_Command);

   type Test_Case is abstract new Test with record
      Routines : Test_Command_List.List  := Test_Command_List.Empty_List;
      Name     : AStrings.Bounded_String := AStrings.Null_Bounded_String;
   end record;
   -- Our test case type. It holds a list of test routines
   -- (test command objects) and the name of the test case.

   procedure Run_Command (Command  :        Test_Command;
                          Info     :        Listeners.Context;
                          Timeout  :        Test_Duration;
                          Listener : in out Listeners.Result_Listener'Class;
                          T        : in out Test_Case'Class);
   -- Handle dispatching to the right Run (Command : Test_Command)
   -- procedure and record test routine result to the Result object.
   --
   -- Timeout parameter defines the longest time the test is allowed
   -- to run. Value 0.0 means infinite time.

   type Test_Class_Wrapper is record
      Ptr : Test_Class_Access;
   end record;

   package Test_List is
     new Ahven.SList (Element_Type => Test_Class_Wrapper);

   package Indefinite_Test_List is
      type List is new Ada.Finalization.Controlled with private;

      Empty_List : constant List;

      procedure Append (Target : in out List; Node_Data : Test'Class);
      -- Append an element at the end of the list.

      procedure Clear (Target : in out List);
      -- Remove all elements from the list.

      generic
         with procedure Action (T : in out Test'Class) is <>;
      procedure For_Each (Target : List);
      -- A generic procedure for walk through every item
      -- in the list and call Action procedure for them.

   private
      type Node;
      type Node_Access is access Node;

      procedure Remove (Ptr : Node_Access);
      -- A procedure to release memory pointed by Ptr.

      type Node is record
         Next : Node_Access       := null;
         Data : Test_Class_Access := null;
      end record;

      type List is new Ada.Finalization.Controlled with record
         First : Node_Access := null;
         Last  : Node_Access := null;
      end record;

      procedure Initialize (Target : in out List);
      procedure Finalize   (Target : in out List);
      procedure Adjust     (Target : in out List);

      Empty_List : constant List :=
        (Ada.Finalization.Controlled with First => null,
                                          Last  => null);
   end Indefinite_Test_List;

   type Test_Suite is new Test with record
      Suite_Name : AStrings.Bounded_String := AStrings.Null_Bounded_String;
      Test_Cases : Test_List.List := Test_List.Empty_List;
      Static_Test_Cases : Indefinite_Test_List.List :=
        Indefinite_Test_List.Empty_List;
   end record;
   -- A suite type which holds a list of test cases and the name
   -- of the suite.

end Ahven.Framework;

Declare the Set_Logging procedure

Declare the Set_Logging procedure


-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012 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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security manager.  The security manager uses a
--  security controller to enforce the permission.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012 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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

Document the policy and policy manager

Document the policy and policy manager


-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body MAT.Formats is

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      return Hex;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

end MAT.Formats;

-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body MAT.Formats is

   Hex_Prefix : Boolean := True;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

end MAT.Formats;

Add support to print an optional 0x prefix to addresses


------------------------------------------------------------------------------
-- Copyright (c) 2014-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Containres provides common containers for all website-wide   --
-- persistent data.                                                         --
------------------------------------------------------------------------------

with Ada.Calendar.Time_Zones;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Streams;
with Natools.Constant_Indefinite_Ordered_Maps;
with Natools.References;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Lockable;
with Natools.Storage_Pools;

package Natools.Web.Containers is

   type Date is record
      Time : Ada.Calendar.Time;
      Offset : Ada.Calendar.Time_Zones.Time_Offset;
   end record;

   package Date_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom, Date, S_Expressions.Less_Than);

   procedure Set_Dates
     (Map : in out Date_Maps.Constant_Map;
      Date_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize date database with then given list

   package Expression_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      S_Expressions.Caches.Cursor,
      S_Expressions.Less_Than,
      S_Expressions.Caches."=");

   procedure Set_Expressions
     (Map : in out Expression_Maps.Constant_Map;
      Expression_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression database with the given list

   package Expression_Map_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      Expression_Maps.Constant_Map,
      S_Expressions.Less_Than,
      Expression_Maps."=");

   procedure Set_Expression_Maps
     (Map : in out Expression_Map_Maps.Constant_Map;
      Expression_Map_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression map database with the given list

   package Unsafe_Atom_Lists is
     new Ada.Containers.Indefinite_Doubly_Linked_Lists
        (S_Expressions.Atom, Ada.Streams."=");

   procedure Append_Atoms
     (Target : in out Unsafe_Atom_Lists.List;
      Expression : in out S_Expressions.Lockable.Descriptor'Class);

   type Atom_Array is array (S_Expressions.Count range <>)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   package Atom_Array_Refs is new References
     (Atom_Array,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create (Source : Unsafe_Atom_Lists.List)
     return Atom_Array_Refs.Immutable_Reference;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Array_Refs.Immutable_Reference;

   package Atom_Row_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Atom_Array_Refs.Immutable_Reference,
      Atom_Array_Refs."=");

   type Atom_Table is array (S_Expressions.Offset range <>)
     of Atom_Array_Refs.Immutable_Reference;

   package Atom_Table_Refs is new References
     (Atom_Table,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Table_Refs.Immutable_Reference;

   function Create
     (Row_List : in Atom_Row_Lists.List)
     return Atom_Table_Refs.Immutable_Reference;

   type Atom_Set is private;

   Null_Atom_Set : constant Atom_Set;

   function Create (Source : in Atom_Array) return Atom_Set;
   function Create (Source : in Unsafe_Atom_Lists.List) return Atom_Set;

   function Contains
     (Set : in Atom_Set;
      Value : in S_Expressions.Atom)
     return Boolean;
   function Contains
     (Set : in Atom_Set;
      Value : in String)
     return Boolean;

   type Identity is record
      User : S_Expressions.Atom_Refs.Immutable_Reference;
      Groups : Atom_Set;
   end record;

   Null_Identity : constant Identity;

private

   type Atom_Set is record
      Elements : Atom_Array_Refs.Immutable_Reference;
   end record;

   Null_Atom_Set : constant Atom_Set
     := (Elements => Atom_Array_Refs.Null_Immutable_Reference);

   Null_Identity : constant Identity
     := (User => S_Expressions.Atom_Refs.Null_Immutable_Reference,
         Groups => Null_Atom_Set);

end Natools.Web.Containers;

------------------------------------------------------------------------------
-- Copyright (c) 2014-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Containres provides common containers for all website-wide   --
-- persistent data.                                                         --
------------------------------------------------------------------------------

with Ada.Calendar.Time_Zones;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Streams;
with Natools.Constant_Indefinite_Ordered_Maps;
with Natools.References;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Lockable;
with Natools.Storage_Pools;

package Natools.Web.Containers is

   type Date is record
      Time : Ada.Calendar.Time;
      Offset : Ada.Calendar.Time_Zones.Time_Offset;
   end record;

   package Date_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom, Date, S_Expressions.Less_Than);

   procedure Set_Dates
     (Map : in out Date_Maps.Constant_Map;
      Date_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize date database with then given list

   package Expression_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      S_Expressions.Caches.Cursor,
      S_Expressions.Less_Than,
      S_Expressions.Caches."=");

   procedure Set_Expressions
     (Map : in out Expression_Maps.Constant_Map;
      Expression_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression database with the given list

   package Expression_Map_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      Expression_Maps.Constant_Map,
      S_Expressions.Less_Than,
      Expression_Maps."=");

   procedure Set_Expression_Maps
     (Map : in out Expression_Map_Maps.Constant_Map;
      Expression_Map_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression map database with the given list

   package Unsafe_Atom_Lists is
     new Ada.Containers.Indefinite_Doubly_Linked_Lists
        (S_Expressions.Atom, Ada.Streams."=");

   procedure Append_Atoms
     (Target : in out Unsafe_Atom_Lists.List;
      Expression : in out S_Expressions.Lockable.Descriptor'Class);

   type Atom_Array is array (S_Expressions.Count range <>)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   package Atom_Array_Refs is new References
     (Atom_Array,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create (Source : Unsafe_Atom_Lists.List)
     return Atom_Array_Refs.Immutable_Reference;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Array_Refs.Immutable_Reference;

   package Atom_Row_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Atom_Array_Refs.Immutable_Reference,
      Atom_Array_Refs."=");

   type Atom_Table is array (S_Expressions.Offset range <>)
     of Atom_Array_Refs.Immutable_Reference;

   package Atom_Table_Refs is new References
     (Atom_Table,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Table_Refs.Immutable_Reference;

   function Create
     (Row_List : in Atom_Row_Lists.List)
     return Atom_Table_Refs.Immutable_Reference;

   type Atom_Set is private;

   Null_Atom_Set : constant Atom_Set;

   function Create (Source : in Atom_Array) return Atom_Set;
   function Create (Source : in Unsafe_Atom_Lists.List) return Atom_Set;

   function Contains
     (Set : in Atom_Set;
      Value : in S_Expressions.Atom)
     return Boolean;
   function Contains
     (Set : in Atom_Set;
      Value : in String)
     return Boolean;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference;

   type Identity is record
      User : S_Expressions.Atom_Refs.Immutable_Reference;
      Groups : Atom_Set;
   end record;

   Null_Identity : constant Identity;

private

   type Atom_Set is record
      Elements : Atom_Array_Refs.Immutable_Reference;
   end record;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference
     is (Set.Elements);

   Null_Atom_Set : constant Atom_Set
     := (Elements => Atom_Array_Refs.Null_Immutable_Reference);

   Null_Identity : constant Identity
     := (User => S_Expressions.Atom_Refs.Null_Immutable_Reference,
         Groups => Null_Atom_Set);

end Natools.Web.Containers;

containers: add an accessor to the array underlying an atom set