-----------------------------------------------------------------------
--  ado-sessions-sources -- Database Sources
--  Copyright (C) 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 ADO.Sessions.Sources is

   --  ------------------------------
   --  The database connection source
   --  ------------------------------
   --  The <b>DataSource</b> is the factory for getting a connection to the database.
   --  It contains the configuration properties to define which database driver must
   --  be used and which connection parameters the driver has to use to establish
   --  the connection.
   type Data_Source is new ADO.Drivers.Connections.Configuration with private;
   type Data_Source_Access is access all Data_Source'Class;

   --  Attempts to establish a connection with the data source
   --  that this Data_Source object represents.
--   procedure Create_Connection (Controller : in Data_Source)
--                         return ADO.Master_Connection'Class;

   --  ------------------------------
   --  Replicated Data Source
   --  ------------------------------
   --  The replicated data source supports a Master/Slave database configuration.
   --  When using this data source, the master is used to execute
   --  update, insert, delete and also query statements.  The slave is used
   --  to execute query statements.  The master and slave are represented by
   --  two separate data sources.  This allows to have a master on one server,
   --  use a specific user/password and get a slave on another server with other
   --  credentials.
   type Replicated_DataSource is new Data_Source with private;
   type Replicated_DataSource_Access is access all Replicated_DataSource'Class;

   --  Set the master data source
   procedure Set_Master (Controller : in out Replicated_DataSource;
                         Master     : in Data_Source_Access);

   --  Get the master data source
   function Get_Master (Controller : in Replicated_DataSource)
                       return Data_Source_Access;

   --  Set the slave data source
   procedure Set_Slave (Controller : in out Replicated_DataSource;
                        Slave      : in Data_Source_Access);

   --  Get the slace data source
   function Get_Slave (Controller : in Replicated_DataSource)
                      return Data_Source_Access;

   --  Get a slave database connection
--   function Get_Slave_Connection (Controller : in Replicated_DataSource)
--                                 return Connection'Class;

private

   type Data_Source is new ADO.Drivers.Connections.Configuration with null record;

   type Replicated_DataSource is new Data_Source with record
      Master : Data_Source_Access := null;
      Slave  : Data_Source_Access := null;
   end record;

end ADO.Sessions.Sources;

-----------------------------------------------------------------------
--  ado-sessions-sources -- Database Sources
--  Copyright (C) 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.
-----------------------------------------------------------------------

--  == Connection string ==
--  The database connection string is an URI that specifies the database driver to use as well
--  as the information for the database driver to connect to the database.
--  The driver connection is a string of the form:
--
--    driver://[host][:port]/[database][?property1][=value1]...
--
--  The database connection string is passed to the session factory that maintains connections
--  to the database (see ADO.Sessions.Factory).
--
package ADO.Sessions.Sources is

   --  ------------------------------
   --  The database connection source
   --  ------------------------------
   --  The <b>DataSource</b> is the factory for getting a connection to the database.
   --  It contains the configuration properties to define which database driver must
   --  be used and which connection parameters the driver has to use to establish
   --  the connection.
   type Data_Source is new ADO.Drivers.Connections.Configuration with private;
   type Data_Source_Access is access all Data_Source'Class;

   --  Attempts to establish a connection with the data source
   --  that this Data_Source object represents.
--   procedure Create_Connection (Controller : in Data_Source)
--                         return ADO.Master_Connection'Class;

   --  ------------------------------
   --  Replicated Data Source
   --  ------------------------------
   --  The replicated data source supports a Master/Slave database configuration.
   --  When using this data source, the master is used to execute
   --  update, insert, delete and also query statements.  The slave is used
   --  to execute query statements.  The master and slave are represented by
   --  two separate data sources.  This allows to have a master on one server,
   --  use a specific user/password and get a slave on another server with other
   --  credentials.
   type Replicated_DataSource is new Data_Source with private;
   type Replicated_DataSource_Access is access all Replicated_DataSource'Class;

   --  Set the master data source
   procedure Set_Master (Controller : in out Replicated_DataSource;
                         Master     : in Data_Source_Access);

   --  Get the master data source
   function Get_Master (Controller : in Replicated_DataSource)
                       return Data_Source_Access;

   --  Set the slave data source
   procedure Set_Slave (Controller : in out Replicated_DataSource;
                        Slave      : in Data_Source_Access);

   --  Get the slace data source
   function Get_Slave (Controller : in Replicated_DataSource)
                      return Data_Source_Access;

   --  Get a slave database connection
--   function Get_Slave_Connection (Controller : in Replicated_DataSource)
--                                 return Connection'Class;

private

   type Data_Source is new ADO.Drivers.Connections.Configuration with null record;

   type Replicated_DataSource is new Data_Source with record
      Master : Data_Source_Access := null;
      Slave  : Data_Source_Access := null;
   end record;

end ADO.Sessions.Sources;

Add some documentation

Add some documentation


-----------------------------------------------------------------------
--  components-util -- ASF Util Components
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------
with ASF.Views;
with ASF.Views.Nodes;
package body ASF.Components.Utils is

   function Get_Line_Info (UI : in Base.UIComponent'Class) return Views.Line_Info;

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in Base.UIComponent'Class) return Views.Line_Info is
      Tag : constant access ASF.Views.Nodes.Tag_Node'Class := UI.Get_Tag;
   begin
      if Tag /= null then
         return Tag.Get_Line_Info;
      else
         return Tag.Get_Line_Info;
      end if;
   end Get_Line_Info;
   pragma Unreferenced (Get_Line_Info);

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in Base.UIComponent'Class) return String is
      Tag : constant access ASF.Views.Nodes.Tag_Node'Class := UI.Get_Tag;
   begin
      if Tag /= null then
         return Tag.Get_Line_Info;
      else
         return Tag.Get_Line_Info;
      end if;
   end Get_Line_Info;

end ASF.Components.Utils;

-----------------------------------------------------------------------
--  components-util -- ASF Util Components
--  Copyright (C) 2009, 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.
-----------------------------------------------------------------------
with ASF.Views;
with ASF.Views.Nodes;
package body ASF.Components.Utils is

   function Get_Line_Info (UI : in Base.UIComponent'Class) return Views.Line_Info;

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in Base.UIComponent'Class) return Views.Line_Info is
      Tag : constant access ASF.Views.Nodes.Tag_Node'Class := UI.Get_Tag;
   begin
      if Tag /= null then
         return Tag.Get_Line_Info;
      else
         return Tag.Get_Line_Info;
      end if;
   end Get_Line_Info;
   pragma Unreferenced (Get_Line_Info);

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in Base.UIComponent'Class) return String is
      Tag : constant access ASF.Views.Nodes.Tag_Node'Class := UI.Get_Tag;
   begin
      if Tag /= null then
         return Tag.Get_Line_Info;
      else
         return "?";
      end if;
   end Get_Line_Info;

end ASF.Components.Utils;

Fix exception in case the component has no associated tag


-----------------------------------------------------------------------
--  gen-commands-propset -- Set a property on dynamo project
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package Gen.Commands.Propset is

   --  ------------------------------
   --  Propset Command
   --  ------------------------------
   --  This command sets a property in the dynamo project configuration.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Propset;

-----------------------------------------------------------------------
--  gen-commands-propset -- Set a property on dynamo project
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package Gen.Commands.Propset is

   --  ------------------------------
   --  Propset Command
   --  ------------------------------
   --  This command sets a property in the dynamo project configuration.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Propset;

Update to use an in out parameter for Help procedure


-----------------------------------------------------------------------
--  gen-model-operations -- Operation declarations
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body Gen.Model.Operations is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Operation_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "parameters" or Name = "columns" then
         return From.Parameters_Bean;

      elsif Name = "return" then
         return Util.Beans.Objects.To_Object (From.Return_Type);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Operation_Definition) is
   begin
      null;
   end Prepare;

   --  ------------------------------
   --  Initialize the operation definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Operation_Definition) is
   begin
      O.Parameters_Bean := Util.Beans.Objects.To_Object (O.Parameters'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);

   end Initialize;

   --  ------------------------------
   --  Add an operation parameter with the given name and type.
   --  ------------------------------
   procedure Add_Parameter (Into      : in out Operation_Definition;
                            Name      : in Unbounded_String;
                            Of_Type   : in Unbounded_String;
                            Parameter : out Parameter_Definition_Access) is
   begin
      Parameter := new Parameter_Definition;
      Parameter.Name := Name;
      Parameter.Type_Name := Of_Type;
      Into.Parameters.Append (Parameter);
   end Add_Parameter;

   --  ------------------------------
   --  Create an operation with the given name.
   --  ------------------------------
   function Create_Operation (Name : in Unbounded_String) return Operation_Definition_Access is
      Result : constant Operation_Definition_Access := new Operation_Definition;
   begin
      return Result;
   end Create_Operation;

end Gen.Model.Operations;

-----------------------------------------------------------------------
--  gen-model-operations -- Operation declarations
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body Gen.Model.Operations is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Operation_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "parameters" or Name = "columns" then
         return From.Parameters_Bean;

      elsif Name = "return" then
         return Util.Beans.Objects.To_Object (From.Return_Type);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Operation_Definition) is
   begin
      null;
   end Prepare;

   --  ------------------------------
   --  Initialize the operation definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Operation_Definition) is
   begin
      O.Parameters_Bean := Util.Beans.Objects.To_Object (O.Parameters'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);

   end Initialize;

   --  ------------------------------
   --  Add an operation parameter with the given name and type.
   --  ------------------------------
   procedure Add_Parameter (Into      : in out Operation_Definition;
                            Name      : in Unbounded_String;
                            Of_Type   : in Unbounded_String;
                            Parameter : out Parameter_Definition_Access) is
   begin
      Parameter := new Parameter_Definition;
      Parameter.Name := Name;
      Parameter.Type_Name := Of_Type;
      Into.Parameters.Append (Parameter);
   end Add_Parameter;

   --  ------------------------------
   --  Create an operation with the given name.
   --  ------------------------------
   function Create_Operation (Name : in Unbounded_String) return Operation_Definition_Access is
      pragma Unreferenced (Name);

      Result : constant Operation_Definition_Access := new Operation_Definition;
   begin
      return Result;
   end Create_Operation;

end Gen.Model.Operations;

Fix compilation warning

Fix compilation warning


------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

package nRF51.Temperature is

   type Temp_Celcius is delta 0.25 range
     -2_147_483_648.0 / 4 .. 2_147_483_647.0 / 4;

   function Read return Temp_Celcius;

end nRF51.Temperature;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

package nRF51.Temperature is

   type Temp_Celsius is delta 0.25 range
     -2_147_483_648.0 / 4 .. 2_147_483_647.0 / 4;

   function Read return Temp_Celsius;

end nRF51.Temperature;

Update nrf51-temperature.ads

Update nrf51-temperature.ads


with Ada.Containers.Ordered_Sets;
with Ada.Strings.Bounded;
with Ada.Unchecked_Deallocation;
with Jack.Thin;
with System;

pragma Elaborate_All (Jack.Thin);

package Jack.Client is

  --
  -- Types.
  --

  type Number_Of_Frames_t is new Thin.Number_Of_Frames_t;

  --
  -- Options
  --

  type Option_Selector_t is
    (Do_Not_Start_Server,
     Use_Exact_Name,
     Server_Name,
     Load_Name,
     Load_Initialize);

  type Options_t is array (Option_Selector_t) of Boolean;

  --
  -- Status
  --

  type Status_Selector_t is
    (Failure,
     Invalid_Option,
     Name_Not_Unique,
     Server_Started,
     Server_Failed,
     Server_Error,
     No_Such_Client,
     Load_Failure,
     Init_Failure,
     Shared_Memory_Failure,
     Version_Error);

  type Status_t is array (Status_Selector_t) of Boolean;

  --
  -- Port flags
  --

  type Port_Flag_Selector_t is
    (Port_Is_Input,
     Port_Is_Output,
     Port_Is_Physical,
     Port_Can_Monitor,
     Port_Is_Terminal);

  type Port_Flags_t is array (Port_Flag_Selector_t) of Boolean;

  --
  -- Client
  --

  type Client_t is limited private;

  Invalid_Client : constant Client_t;

  function Compare
    (Left  : in Client_t;
     Right : in Client_t) return Boolean;

  function "="
    (Left  : in Client_t;
     Right : in Client_t) return Boolean renames Compare;

  --
  -- Port
  --

  type Port_t is limited private;

  Invalid_Port : constant Port_t;

  --
  -- Port name
  --

  subtype Port_Name_Size_t  is Natural          range 0 .. Natural (Thin.Port_Name_Size);
  subtype Port_Name_Index_t is Port_Name_Size_t range 1 .. Port_Name_Size_t'Last;

  package Port_Names is new
    Ada.Strings.Bounded.Generic_Bounded_Length (Port_Name_Index_t'Last);

  subtype Port_Name_t is Port_Names.Bounded_String;

  package Port_Name_Sets is new Ada.Containers.Ordered_Sets
    (Element_Type => Port_Name_t,
     "="          => Port_Names."=",
     "<"          => Port_Names."<");

  subtype Port_Name_Set_t is Port_Name_Sets.Set;

  --
  -- API
  --

  -- proc_map : jack_client_close
  procedure Close
    (Client : in     Client_t;
     Failed :    out Boolean);

  -- proc_map : jack_connect
  procedure Connect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean);

  -- proc_map : jack_disconnect
  procedure Disconnect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean);

  -- proc_map : jack_client_open
  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t);

  -- proc_map : jack_port_register
  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String;
     Port_Flags  : in     Port_Flags_t;
     Buffer_Size : in     Natural := 0);

  -- proc_map : jack_activate
  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean);

  -- proc_map : jack_get_ports
  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String;
     Port_Type_Pattern : in     String;
     Port_Flags        : in     Port_Flags_t;
     Ports             :    out Port_Name_Set_t);

  generic
    type User_Data_Type        is private;
    type User_Data_Access_Type is access User_Data_Type;

  package Generic_Callbacks is

    type Process_Callback_State_t is record
      Callback  : access procedure
        (Number_Of_Frames : in Number_Of_Frames_t;
         User_Data        : in User_Data_Access_Type);
      User_Data : User_Data_Access_Type;
    end record;

    type Process_Callback_State_Access_t is access Process_Callback_State_t;

    procedure Deallocate_State is new Ada.Unchecked_Deallocation
      (Object => User_Data_Type,
       Name   => User_Data_Access_Type);

    -- proc_map : jack_set_process_callback
    procedure Set_Process_Callback
      (Client    : in     Client_t;
       State     : in     Process_Callback_State_Access_t;
       Failed    :    out Boolean);

  end Generic_Callbacks;

  --
  -- Private
  --

  function To_Address (Client : in Client_t) return System.Address;
  pragma Inline (To_Address);

  function To_Address (Port : in Port_t) return System.Address;
  pragma Inline (To_Address);

private

  type Client_t is new System.Address;
  type Port_t   is new System.Address;

  Invalid_Client : constant Client_t := Client_t (System.Null_Address);
  Invalid_Port   : constant Port_t   := Port_t (System.Null_Address);

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t;
  pragma Inline (Map_Status_To_Thin);

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t;
  pragma Inline (Map_Thin_To_Status);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t;
  pragma Inline (Map_Options_To_Thin);

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t;
  pragma Inline (Map_Thin_To_Options);

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t;
  pragma Inline (Map_Port_Flags_To_Thin);

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t;
  pragma Inline (Map_Thin_To_Port_Flags);

end Jack.Client;

with Ada.Containers.Ordered_Sets;
with Ada.Strings.Bounded;
with Ada.Unchecked_Deallocation;
with Jack.Thin;
with System;

pragma Elaborate_All (Jack.Thin);

package Jack.Client is

  --
  -- Types.
  --

  type Number_Of_Frames_t is new Thin.Number_Of_Frames_t;

  --
  -- Options
  --

  type Option_Selector_t is
    (Do_Not_Start_Server,
     Use_Exact_Name,
     Server_Name,
     Load_Name,
     Load_Initialize);

  type Options_t is array (Option_Selector_t) of Boolean;

  --
  -- Status
  --

  type Status_Selector_t is
    (Failure,
     Invalid_Option,
     Name_Not_Unique,
     Server_Started,
     Server_Failed,
     Server_Error,
     No_Such_Client,
     Load_Failure,
     Init_Failure,
     Shared_Memory_Failure,
     Version_Error);

  type Status_t is array (Status_Selector_t) of Boolean;

  --
  -- Port flags
  --

  type Port_Flag_Selector_t is
    (Port_Is_Input,
     Port_Is_Output,
     Port_Is_Physical,
     Port_Can_Monitor,
     Port_Is_Terminal);

  type Port_Flags_t is array (Port_Flag_Selector_t) of Boolean;

  --
  -- Client
  --

  type Client_t is limited private;

  Invalid_Client : constant Client_t;

  function Compare
    (Left  : in Client_t;
     Right : in Client_t) return Boolean;

  function "="
    (Left  : in Client_t;
     Right : in Client_t) return Boolean renames Compare;

  --
  -- Port
  --

  type Port_t is limited private;

  Invalid_Port : constant Port_t;

  --
  -- Port name
  --

  subtype Port_Name_Size_t  is Natural          range 0 .. Natural (Thin.Port_Name_Size);
  subtype Port_Name_Index_t is Port_Name_Size_t range 1 .. Port_Name_Size_t'Last;

  package Port_Names is new
    Ada.Strings.Bounded.Generic_Bounded_Length (Port_Name_Index_t'Last);

  subtype Port_Name_t is Port_Names.Bounded_String;

  package Port_Name_Sets is new Ada.Containers.Ordered_Sets
    (Element_Type => Port_Name_t,
     "="          => Port_Names."=",
     "<"          => Port_Names."<");

  subtype Port_Name_Set_t is Port_Name_Sets.Set;

  Default_Audio_Type : constant Port_Name_t :=
    Port_Names.To_Bounded_String ("32 bit float mono audio");

  --
  -- API
  --

  -- proc_map : jack_client_close
  procedure Close
    (Client : in     Client_t;
     Failed :    out Boolean);

  -- proc_map : jack_connect
  procedure Connect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean);

  -- proc_map : jack_disconnect
  procedure Disconnect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean);

  -- proc_map : jack_client_open
  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t);

  -- proc_map : jack_port_register
  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String;
     Port_Flags  : in     Port_Flags_t;
     Buffer_Size : in     Natural := 0);

  -- proc_map : jack_activate
  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean);

  -- proc_map : jack_get_ports
  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String;
     Port_Type_Pattern : in     String;
     Port_Flags        : in     Port_Flags_t;
     Ports             :    out Port_Name_Set_t);

  generic
    type User_Data_Type        is private;
    type User_Data_Access_Type is access User_Data_Type;

  package Generic_Callbacks is

    type Process_Callback_State_t is record
      Callback  : access procedure
        (Number_Of_Frames : in Number_Of_Frames_t;
         User_Data        : in User_Data_Access_Type);
      User_Data : User_Data_Access_Type;
    end record;

    type Process_Callback_State_Access_t is access Process_Callback_State_t;

    procedure Deallocate_State is new Ada.Unchecked_Deallocation
      (Object => User_Data_Type,
       Name   => User_Data_Access_Type);

    -- proc_map : jack_set_process_callback
    procedure Set_Process_Callback
      (Client    : in     Client_t;
       State     : in     Process_Callback_State_Access_t;
       Failed    :    out Boolean);

  end Generic_Callbacks;

  --
  -- Private
  --

  function To_Address (Client : in Client_t) return System.Address;
  pragma Inline (To_Address);

  function To_Address (Port : in Port_t) return System.Address;
  pragma Inline (To_Address);

private

  type Client_t is new System.Address;
  type Port_t   is new System.Address;

  Invalid_Client : constant Client_t := Client_t (System.Null_Address);
  Invalid_Port   : constant Port_t   := Port_t (System.Null_Address);

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t;
  pragma Inline (Map_Status_To_Thin);

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t;
  pragma Inline (Map_Thin_To_Status);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t;
  pragma Inline (Map_Options_To_Thin);

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t;
  pragma Inline (Map_Thin_To_Options);

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t;
  pragma Inline (Map_Port_Flags_To_Thin);

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t;
  pragma Inline (Map_Thin_To_Port_Flags);

end Jack.Client;

Add Default_Audio_Type

Add Default_Audio_Type


-----------------------------------------------------------------------
--  security-oauth-file_registry -- File Based Application and Realm
--  Copyright (C) 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 Util.Encoders.HMAC.SHA1;

package body Security.OAuth.File_Registry is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in File_Principal) return String is
   begin
      return To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   --  ------------------------------
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class is
      Pos : constant Application_Maps.Cursor := Realm.Applications.Find (Client_Id);
   begin
      if not Application_Maps.Has_Element (Pos) then
         raise Servers.Invalid_Application;
      end if;
      return Application_Maps.Element (Pos);
   end Find_Application;

   --  ------------------------------
   --  Add the application to the application repository.
   --  ------------------------------
   procedure Add_Application (Realm : in out File_Application_Manager;
                              App   : in Servers.Application) is
   begin
      Realm.Applications.Include (App.Get_Application_Identifier, App);
   end Add_Application;

   --  ------------------------------
   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   --  ------------------------------
   overriding
   procedure Authenticate (Realm     : in out File_Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is
      Pos : constant Token_Maps.Cursor := Realm.Tokens.Find (Token);
   begin
      if Token_Maps.Has_Element (Pos) then
         Auth := Token_Maps.Element (Pos).all'Access;
      else
         Auth := null;
      end if;
      Cacheable := True;
   end Authenticate;

   --  ------------------------------
   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   --  ------------------------------
   overriding
   function Authorize (Realm : in File_Realm_Manager;
                       App   : in Servers.Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is
   begin
      return To_String (File_Principal (Auth.all).Token);
   end Authorize;

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is
      Result : File_Principal_Access;
      Pos    : constant User_Maps.Cursor := Realm.Users.Find (Username);
   begin
      if not User_Maps.Has_Element (Pos) then
         Auth := null;
         return;
      end if;

      --  Verify that the crypt password with the recorded salt are the same.
      declare
         Expect : constant String := User_Maps.Element (Pos);
         Hash   : constant String := Realm.Crypt_Password (Expect, Password);
      begin
         if Hash /= Expect then
            Auth := null;
            return;
         end if;
      end;

      --  Generate a random token and make the principal to record it.
      declare
         Token : constant String := Realm.Random.Generate (Realm.Token_Bits);
      begin
         Result := new File_Principal;
         Ada.Strings.Unbounded.Append (Result.Token, Token);
         Ada.Strings.Unbounded.Append (Result.Name, Username);
         Realm.Tokens.Insert (Token, Result);
      end;
      Auth := Result.all'Access;
   end Verify;

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is
   begin
      null;
   end Verify;

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access) is
   begin
      if Auth /= null and then Auth.all in File_Principal'Class then
         Realm.Tokens.Delete (To_String (File_Principal (Auth.all).Token));
      end if;
   end Revoke;

   --  ------------------------------
   --  Crypt the password using the given salt and return the string composed with
   --  the salt in clear text and the crypted password.
   --  ------------------------------
   function Crypt_Password (Realm    : in File_Realm_Manager;
                            Salt     : in String;
                            Password : in String) return String is
      pragma Unreferenced (Realm);

      Pos : Natural := Util.Strings.Index (Salt, ' ');
   begin
      if Pos = 0 then
         Pos := Salt'Last;
      else
         Pos := Pos - 1;
      end if;
      return Salt (Salt'First .. Pos) & " "
         & Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => Salt (Salt'First .. Pos),
                                                Data => Password,
                                                URL  => True);
   end Crypt_Password;

   --  ------------------------------
   --  Add a username with the associated password.
   --  ------------------------------
   procedure Add_User (Realm    : in out File_Realm_Manager;
                       Username : in String;
                       Password : in String) is
      Salt : constant String := Realm.Random.Generate (Realm.Token_Bits);
   begin
      Realm.Users.Include (Username, Realm.Crypt_Password (Salt, Password));
   end Add_User;

end Security.OAuth.File_Registry;

-----------------------------------------------------------------------
--  security-oauth-file_registry -- File Based Application and Realm
--  Copyright (C) 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 Util.Encoders.HMAC.SHA1;
with Util.Log.Loggers;

package body Security.OAuth.File_Registry is

   Log : constant Util.Log.Loggers.Logger
     := Util.Log.Loggers.Create ("Security.OAuth.File_Registry");

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in File_Principal) return String is
   begin
      return To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   --  ------------------------------
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class is
      Pos : constant Application_Maps.Cursor := Realm.Applications.Find (Client_Id);
   begin
      if not Application_Maps.Has_Element (Pos) then
         raise Servers.Invalid_Application;
      end if;
      return Application_Maps.Element (Pos);
   end Find_Application;

   --  ------------------------------
   --  Add the application to the application repository.
   --  ------------------------------
   procedure Add_Application (Realm : in out File_Application_Manager;
                              App   : in Servers.Application) is
   begin
      Realm.Applications.Include (App.Get_Application_Identifier, App);
   end Add_Application;

   --  ------------------------------
   --  Load from the properties the definition of applications.  The list of applications
   --  is controled by the property <prefix>.list which contains a comma separated list of
   --  application names or ids.  The application definition are represented by properties
   --  of the form:
   --    <prefix>.<app>.client_id
   --    <prefix>.<app>.client_secret
   --    <prefix>.<app>.callback_url
   --  ------------------------------
   procedure Load (Realm  : in out File_Application_Manager;
                   Props  : in Util.Properties.Manager'Class;
                   Prefix : in String) is
      procedure Configure (Basename : in String);

      procedure Configure (Basename : in String) is
         App : Servers.Application;
      begin
         App.Set_Application_Identifier (Props.Get (Basename & ".client_id"));
         App.Set_Application_Secret (Props.Get (Basename & ".client_secret"));
         App.Set_Application_Callback (Props.Get (Basename & ".callback_url", ""));
         Realm.Add_Application (App);
      end Configure;

      List  : constant String := Props.Get (Prefix & ".list");
      First : Natural := List'First;
      Last  : Natural;
      Count : Natural := 0;
   begin
      Log.Info ("Loading application with prefix {0}", Prefix);
      while First <= List'Last loop
         Last := Util.Strings.Index (Source => List, Char => ',', From => First);
         if Last = 0 then
            Last := List'Last;
         else
            Last := Last - 1;
         end if;
         begin
            Configure (Prefix & "." & List (First .. Last));
            Count := Count + 1;
         exception
            when others =>
               Log.Error ("Invalid application definition {0}",
                          Prefix & "." & List (First .. Last));
         end;
         First := Last + 2;
      end loop;
      Log.Info ("Loaded {0} applications", Util.Strings.Image (Count));
   end Load;

   procedure Load (Realm  : in out File_Application_Manager;
                   Path   : in String;
                   Prefix : in String) is
      Props : Util.Properties.Manager;
   begin
      Log.Info ("Loading application with prefix {0} from {1}", Prefix, Path);
      Props.Load_Properties (Path);
      Realm.Load (Props, Prefix);
   end Load;

   --  ------------------------------
   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   --  ------------------------------
   overriding
   procedure Authenticate (Realm     : in out File_Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is
      Pos : constant Token_Maps.Cursor := Realm.Tokens.Find (Token);
   begin
      if Token_Maps.Has_Element (Pos) then
         Auth := Token_Maps.Element (Pos).all'Access;
      else
         Auth := null;
      end if;
      Cacheable := True;
   end Authenticate;

   --  ------------------------------
   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   --  ------------------------------
   overriding
   function Authorize (Realm : in File_Realm_Manager;
                       App   : in Servers.Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is
   begin
      return To_String (File_Principal (Auth.all).Token);
   end Authorize;

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is
      Result : File_Principal_Access;
      Pos    : constant User_Maps.Cursor := Realm.Users.Find (Username);
   begin
      if not User_Maps.Has_Element (Pos) then
         Auth := null;
         return;
      end if;

      --  Verify that the crypt password with the recorded salt are the same.
      declare
         Expect : constant String := User_Maps.Element (Pos);
         Hash   : constant String := Realm.Crypt_Password (Expect, Password);
      begin
         if Hash /= Expect then
            Auth := null;
            return;
         end if;
      end;

      --  Generate a random token and make the principal to record it.
      declare
         Token : constant String := Realm.Random.Generate (Realm.Token_Bits);
      begin
         Result := new File_Principal;
         Ada.Strings.Unbounded.Append (Result.Token, Token);
         Ada.Strings.Unbounded.Append (Result.Name, Username);
         Realm.Tokens.Insert (Token, Result);
      end;
      Auth := Result.all'Access;
   end Verify;

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is
   begin
      null;
   end Verify;

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access) is
   begin
      if Auth /= null and then Auth.all in File_Principal'Class then
         Realm.Tokens.Delete (To_String (File_Principal (Auth.all).Token));
      end if;
   end Revoke;

   --  ------------------------------
   --  Crypt the password using the given salt and return the string composed with
   --  the salt in clear text and the crypted password.
   --  ------------------------------
   function Crypt_Password (Realm    : in File_Realm_Manager;
                            Salt     : in String;
                            Password : in String) return String is
      pragma Unreferenced (Realm);

      Pos : Natural := Util.Strings.Index (Salt, ' ');
   begin
      if Pos = 0 then
         Pos := Salt'Last;
      else
         Pos := Pos - 1;
      end if;
      return Salt (Salt'First .. Pos) & " "
         & Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => Salt (Salt'First .. Pos),
                                                Data => Password,
                                                URL  => True);
   end Crypt_Password;

   --  ------------------------------
   --  Add a username with the associated password.
   --  ------------------------------
   procedure Add_User (Realm    : in out File_Realm_Manager;
                       Username : in String;
                       Password : in String) is
      Salt : constant String := Realm.Random.Generate (Realm.Token_Bits);
   begin
      Realm.Users.Include (Username, Realm.Crypt_Password (Salt, Password));
   end Add_User;

end Security.OAuth.File_Registry;

Implement the Load procedure to load application definitions from a property file


-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 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.
-----------------------------------------------------------------------
with Ada.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with ASF.Server.Tests;
with ASF.Server.Web;
with ASF.Converters.Dates;

with ASF.Tests;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;

--  with AWA.Applications;
with AWA.Applications.Factory;
with AWA.Services.Filters;
with AWA.Services.Contexts;
package body AWA.Tests is

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new AWA.Applications.Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");

      if Add_Modules then
         declare
            Ctx    : AWA.Services.Contexts.Service_Context;
            Users : constant AWA.Users.Modules.User_Module_Access := AWA.Tests.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

end AWA.Tests;

-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 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.
-----------------------------------------------------------------------
with Ada.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with ASF.Server.Tests;
with ASF.Server.Web;
with ASF.Converters.Dates;

with ASF.Tests;

with AWA.Converters.Dates;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;

--  with AWA.Applications;
with AWA.Applications.Factory;
with AWA.Services.Filters;
with AWA.Services.Contexts;
package body AWA.Tests is

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new AWA.Applications.Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");

      if Add_Modules then
         declare
            Ctx    : AWA.Services.Contexts.Service_Context;
            Users : constant AWA.Users.Modules.User_Module_Access := AWA.Tests.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

end AWA.Tests;

Add a relative date converter

Add a relative date converter


-----------------------------------------------------------------------
--  wiki-parsers-markdown -- Markdown parser operations
--  Copyright (C) 2016 - 2022 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.
-----------------------------------------------------------------------

private package Wiki.Parsers.Markdown is

   pragma Preelaborate;
   subtype Parser_Type is Parser;

   --  Parse a markdown table/column.
   --  Example:
   --    | col1 | col2 | ... | colN |
   procedure Parse_Table (P     : in out Parser;
                          Token : in Wiki.Strings.WChar);

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access);

   procedure Parse_Inline_Text (Parser : in out Parser_Type;
                                Text   : in Wiki.Buffers.Buffer_Access);

end Wiki.Parsers.Markdown;

-----------------------------------------------------------------------
--  wiki-parsers-markdown -- Markdown parser operations
--  Copyright (C) 2016 - 2022 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.
-----------------------------------------------------------------------

private package Wiki.Parsers.Markdown is

   pragma Preelaborate;
   subtype Parser_Type is Parser;

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access);

   procedure Parse_Inline_Text (Parser : in out Parser_Type;
                                Text   : in Wiki.Buffers.Buffer_Access);

end Wiki.Parsers.Markdown;

Remove declaration of internal Parse_Table procedure


-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  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.
-----------------------------------------------------------------------
pragma Ada_2012;
with Babel.Files.Signatures;
with Util.Encoders.SHA1;
with Util.Log.Loggers;

package body Babel.Strategies.Default is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Strategies.Default");

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean is
   begin
      return false; --  not Strategy.Queue.Directories.Is_Empty;
   end Has_Directory;

   --  Get the next directory that must be processed by the strategy.
   overriding
   procedure Peek_Directory (Strategy  : in out Default_Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is
      Last : constant String := ""; --  Strategy.Queue.Directories.Last_Element;
   begin
      --        Strategy.Queue.Directories.Delete_Last;
      null;
   end Peek_Directory;

   --  Set the file queue that the strategy must use.
   procedure Set_Queue (Strategy : in out Default_Strategy_Type;
                        Queue    : in Babel.Files.Queues.File_Queue_Access) is
   begin
      Strategy.Queue := Queue;
   end Set_Queue;

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type) is
      use type Babel.Files.File_Type;

      Content : Babel.Files.Buffers.Buffer_Access := Strategy.Allocate_Buffer;
      File    : Babel.Files.File_Type;
      SHA1    : Util.Encoders.SHA1.Hash_Array;
   begin
      Strategy.Queue.Queue.Dequeue (File, 10.0);
      if File = Babel.Files.NO_FILE then
         Log.Debug ("Dequeue NO_FILE");
         Strategy.Release_Buffer (Content);
      else
         Log.Debug ("Dequeue {0}", Babel.Files.Get_Path (File));
         Strategy.Read_File (File, Content);
         Babel.Files.Signatures.Sha1 (Content.all, SHA1);
         Babel.Files.Set_Signature (File, SHA1);
         if Babel.Files.Is_Modified (File) then
            Strategy.Backup_File (File, Content);
         else
            Strategy.Release_Buffer (Content);
         end if;
      end if;

   exception
      when others =>
         Strategy.Release_Buffer (Content);
         raise;
   end Execute;

   --  Scan the directory
   overriding
   procedure Scan (Strategy  : in out Default_Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Add_Queue (File : in Babel.Files.File_Type) is
      begin
         Log.Debug ("Queueing {0}", Babel.Files.Get_Path (File));
         Strategy.Queue.Add_File (File);
      end Add_Queue;

   begin
      Strategy_Type (Strategy).Scan (Directory, Container);
      Container.Each_File (Add_Queue'Access);
   end Scan;

--     overriding
--     procedure Add_File (Into    : in out Default_Strategy_Type;
--                         Path    : in String;
--                         Element : in Babel.Files.File) is
--     begin
--        Into.Queue.Add_File (Path, Element);
--     end Add_File;
--
--     overriding
--     procedure Add_Directory (Into : in out Default_Strategy_Type;
--                              Path : in String;
--                              Name : in String) is
--     begin
--        Into.Queue.Add_Directory (Path, Name);
--     end Add_Directory;

end Babel.Strategies.Default;

-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014, 2015, 2016 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.
-----------------------------------------------------------------------
pragma Ada_2012;
with Babel.Files.Signatures;
with Util.Encoders.SHA1;
with Util.Log.Loggers;

with Babel.Streams.Refs;
package body Babel.Strategies.Default is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Strategies.Default");

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean is
   begin
      return false; --  not Strategy.Queue.Directories.Is_Empty;
   end Has_Directory;

   --  Get the next directory that must be processed by the strategy.
   overriding
   procedure Peek_Directory (Strategy  : in out Default_Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is
      Last : constant String := ""; --  Strategy.Queue.Directories.Last_Element;
   begin
      --        Strategy.Queue.Directories.Delete_Last;
      null;
   end Peek_Directory;

   --  Set the file queue that the strategy must use.
   procedure Set_Queue (Strategy : in out Default_Strategy_Type;
                        Queue    : in Babel.Files.Queues.File_Queue_Access) is
   begin
      Strategy.Queue := Queue;
   end Set_Queue;

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type) is
      use type Babel.Files.File_Type;

      Content : Babel.Files.Buffers.Buffer_Access := Strategy.Allocate_Buffer;
      File    : Babel.Files.File_Type;
      SHA1    : Util.Encoders.SHA1.Hash_Array;
      Stream  : Babel.Streams.Refs.Stream_Ref;
   begin
      Strategy.Queue.Queue.Dequeue (File, 10.0);
      if File = Babel.Files.NO_FILE then
         Log.Debug ("Dequeue NO_FILE");
         Strategy.Release_Buffer (Content);
      else
         Log.Debug ("Dequeue {0}", Babel.Files.Get_Path (File));
         Strategy.Read_File (File, Stream);
         Babel.Files.Signatures.Sha1 (Stream, SHA1);
         Babel.Files.Set_Signature (File, SHA1);
         if Babel.Files.Is_Modified (File) then
            Strategy.Backup_File (File, Stream);
         else
            Strategy.Release_Buffer (Content);
         end if;
      end if;

   exception
      when others =>
         Strategy.Release_Buffer (Content);
         raise;
   end Execute;

   --  Scan the directory
   overriding
   procedure Scan (Strategy  : in out Default_Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Add_Queue (File : in Babel.Files.File_Type) is
      begin
         Log.Debug ("Queueing {0}", Babel.Files.Get_Path (File));
         Strategy.Queue.Add_File (File);
      end Add_Queue;

   begin
      Strategy_Type (Strategy).Scan (Directory, Container);
      Container.Each_File (Add_Queue'Access);
   end Scan;

--     overriding
--     procedure Add_File (Into    : in out Default_Strategy_Type;
--                         Path    : in String;
--                         Element : in Babel.Files.File) is
--     begin
--        Into.Queue.Add_File (Path, Element);
--     end Add_File;
--
--     overriding
--     procedure Add_Directory (Into : in out Default_Strategy_Type;
--                              Path : in String;
--                              Name : in String) is
--     begin
--        Into.Queue.Add_Directory (Path, Name);
--     end Add_Directory;

end Babel.Strategies.Default;

Use the Read_File and Write_File operation on a stream for the backup


-----------------------------------------------------------------------
--  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 Interfaces;
with System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   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 : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         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;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + Storage_Offset (1));
      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;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : constant 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 =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            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;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

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 Interfaces;
with System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Marshaller");

   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 : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   --  ------------------------------
   --  Get a 16-bit value either from big-endian or little endian.
   --  ------------------------------
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + Storage_Offset (1));
      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;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : constant 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 =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            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;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

end MAT.Readers.Marshaller;

Document Get_Uint16

Document Get_Uint16