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

   use Util.Beans.Objects;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            P.First_Name := To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            P.Last_Name := To_Unbounded_String (Value);

         when FIELD_AGE =>
            P.Age := To_Integer (Value);

      end case;
   end Set_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            return Util.Beans.Objects.To_Object (From.First_Name);

         when FIELD_LAST_NAME =>
            return Util.Beans.Objects.To_Object (From.Last_Name);

         when FIELD_AGE =>
            return Util.Beans.Objects.To_Object (From.Age);

      end case;
   end Get_Person_Member;

   type Address_Fields is (FIELD_CITY, FIELD_STREET, FIELD_COUNTRY, FIELD_ZIP);
   type Address_Access is access all Address;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
       case Field is
         when FIELD_CITY =>
            Addr.City := To_Unbounded_String (Value);

         when FIELD_STREET =>
            Addr.Street := To_Unbounded_String (Value);

         when FIELD_COUNTRY =>
            Addr.Country := To_Unbounded_String (Value);

         when FIELD_ZIP =>
            Addr.Zip := To_Integer (Value);

      end case;
   end Set_Member;

   function Get_Member (Addr  : in Address;
                        Field : in Address_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_CITY =>
            return Util.Beans.Objects.To_Object (Addr.City);

         when FIELD_STREET =>
            return Util.Beans.Objects.To_Object (Addr.Street);

         when FIELD_COUNTRY =>
            return Util.Beans.Objects.To_Object (Addr.Country);

         when FIELD_ZIP =>
            return Util.Beans.Objects.To_Object (Addr.Zip);

      end case;
   end Get_Member;

   package Address_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Address,
                                               Element_Type_Access => Address_Access,
                                               Fields              => Address_Fields,
                                               Set_Member          => Set_Member);

   --  Mapping for the Address record.
   Address_Mapping       : aliased Address_Mapper.Mapper;

   --  Mapping for the Person record.
   Person_Mapping        : aliased Person_Mapper.Mapper;

   --  Mapping for a list of Person records (stored as a Vector).
   Person_Vector_Mapping : aliased Person_Vector_Mapper.Mapper;

   --  ------------------------------
   --  Get the address mapper which describes how to load an Address.
   --  ------------------------------
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Address_Mapping'Access;
   end Get_Address_Mapper;

   --  ------------------------------
   --  Get the person mapper which describes how to load a Person.
   --  ------------------------------
   function Get_Person_Mapper return Person_Mapper.Mapper_Access is
   begin
      return Person_Mapping'Access;
   end Get_Person_Mapper;

   --  ------------------------------
   --  Get the person vector mapper which describes how to load a list of Person.
   --  ------------------------------
   function Get_Person_Vector_Mapper return Person_Vector_Mapper.Mapper_Access is
   begin
      return Person_Vector_Mapping'Access;
   end Get_Person_Vector_Mapper;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------
   procedure Person_Address (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                             Process : not null access procedure (Item : in out Address)) is
      procedure Process_Person (P : in out Person) is
      begin
         Process (P.Addr);
      end Process_Person;
   begin
      Person_Mapper.Execute_Object (Ctx, Process_Person'Access);
   end Person_Address;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------
--     procedure Proxy_Person_Address (Element : in out Person;
--                                     Process : not null access procedure (Item : in out Address)) is
--     begin
--        Process (Element.Addr);
--     end Proxy_Person_Address;

begin
   --  XML:                                JSON:
   --  ----                                -----
   --  <city>Paris</city>                  "city" : "Paris"
   --  <street>Champs de Mars</street>     "street" : "Champs de Mars"
   --  <country>France</country>           "country" : "France"
   --  <zip>75</zip>                       "zip" : 75
   Address_Mapping.Bind (Person_Address'Access);
   Address_Mapping.Bind (Get_Member'Access);
   Address_Mapping.Add_Default_Mapping;

   --  XML:
   --  ----
   --  <xxx id='23'>
   --     <address>
   --        <city>...</city>
   --        <street number='44'>..</street>
   --        <country>..</country>
   --        <zip>..</zip>
   --     </address>
   --     <name>John</name>
   --     <last_name>Harry</last_name>
   --     <age>23</age>
   --     <info><facebook><id>...</id></facebook></info>
   --  </xxx>
   --  Person_Mapper.Add_Mapping ("@id");
   Person_Mapping.Bind (Get_Person_Member'Access);
   Person_Mapping.Add_Mapping ("address", Address_Mapping'Access);
   Person_Mapping.Add_Mapping ("name", FIELD_FIRST_NAME);
   Person_Mapping.Add_Default_Mapping;
  --   Person_Mapper.Add_Mapping ("info/*");
   --  Person_Mapper.Add_Mapping ("address/street/@number");

   Person_Vector_Mapping.Set_Mapping ("person", Person_Mapping);
end Mapping;

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

   use Util.Beans.Objects;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            P.First_Name := To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            P.Last_Name := To_Unbounded_String (Value);

         when FIELD_AGE =>
            P.Age := To_Integer (Value);

      end case;
   end Set_Member;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_FIRST_NAME =>
            return Util.Beans.Objects.To_Object (From.First_Name);

         when FIELD_LAST_NAME =>
            return Util.Beans.Objects.To_Object (From.Last_Name);

         when FIELD_AGE =>
            return Util.Beans.Objects.To_Object (From.Age);

      end case;
   end Get_Person_Member;

   type Address_Fields is (FIELD_CITY, FIELD_STREET, FIELD_COUNTRY, FIELD_ZIP);
   type Address_Access is access all Address;

   --  ------------------------------
   --  Set the name/value pair on the current object.
   --  ------------------------------
   procedure Set_Member (Addr  : in out Address;
                         Field : in Address_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
       case Field is
         when FIELD_CITY =>
            Addr.City := To_Unbounded_String (Value);

         when FIELD_STREET =>
            Addr.Street := To_Unbounded_String (Value);

         when FIELD_COUNTRY =>
            Addr.Country := To_Unbounded_String (Value);

         when FIELD_ZIP =>
            Addr.Zip := To_Integer (Value);

      end case;
   end Set_Member;

   function Get_Member (Addr  : in Address;
                        Field : in Address_Fields) return Util.Beans.Objects.Object is
   begin
      case Field is
         when FIELD_CITY =>
            return Util.Beans.Objects.To_Object (Addr.City);

         when FIELD_STREET =>
            return Util.Beans.Objects.To_Object (Addr.Street);

         when FIELD_COUNTRY =>
            return Util.Beans.Objects.To_Object (Addr.Country);

         when FIELD_ZIP =>
            return Util.Beans.Objects.To_Object (Addr.Zip);

      end case;
   end Get_Member;

   package Address_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Address,
                                               Element_Type_Access => Address_Access,
                                               Fields              => Address_Fields,
                                               Set_Member          => Set_Member);

   --  Mapping for the Address record.
   Address_Mapping       : aliased Address_Mapper.Mapper;

   --  Mapping for the Person record.
   Person_Mapping        : aliased Person_Mapper.Mapper;

   --  Mapping for a list of Person records (stored as a Vector).
   Person_Vector_Mapping : aliased Person_Vector_Mapper.Mapper;

   --  ------------------------------
   --  Get the address mapper which describes how to load an Address.
   --  ------------------------------
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access is
   begin
      return Address_Mapping'Access;
   end Get_Address_Mapper;

   --  ------------------------------
   --  Get the person mapper which describes how to load a Person.
   --  ------------------------------
   function Get_Person_Mapper return Person_Mapper.Mapper_Access is
   begin
      return Person_Mapping'Access;
   end Get_Person_Mapper;

   --  ------------------------------
   --  Get the person vector mapper which describes how to load a list of Person.
   --  ------------------------------
   function Get_Person_Vector_Mapper return Person_Vector_Mapper.Mapper_Access is
   begin
      return Person_Vector_Mapping'Access;
   end Get_Person_Vector_Mapper;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------

   procedure Proxy_Info (Attr : in Util.Serialize.Mappers.Mapping'Class;
                         Element : in out Address;
                         Value   : in Util.Beans.Objects.Object) is
   begin
      --        Info_Mapper.Set_Member (Attr, Element.Info, Value);
      null;
   end Proxy_Info;

   procedure Proxy_Address (Attr    : in Util.Serialize.Mappers.Mapping'Class;
                            Element : in out Person;
                            Value   : in Util.Beans.Objects.Object) is
   begin
      Address_Mapper.Set_Member (Attr, Element.Addr, Value);
   end Proxy_Address;

   --  ------------------------------
   --  Helper to give access to the Address member of a Person.
   --  ------------------------------
--     procedure Proxy_Person_Address (Element : in out Person;
--                                     Process : not null access procedure (Item : in out Address)) is
--     begin
--        Process (Element.Addr);
--     end Proxy_Person_Address;

begin
   --  XML:                                JSON:
   --  ----                                -----
   --  <city>Paris</city>                  "city" : "Paris"
   --  <street>Champs de Mars</street>     "street" : "Champs de Mars"
   --  <country>France</country>           "country" : "France"
   --  <zip>75</zip>                       "zip" : 75
   Address_Mapping.Bind (Get_Member'Access);
--     Address_Mapping.Add_Mapping ("info", Info_Mapping, Proxy_Info'Access);
   Address_Mapping.Add_Default_Mapping;

   --  XML:
   --  ----
   --  <xxx id='23'>
   --     <address>
   --        <city>...</city>
   --        <street number='44'>..</street>
   --        <country>..</country>
   --        <zip>..</zip>
   --     </address>
   --     <name>John</name>
   --     <last_name>Harry</last_name>
   --     <age>23</age>
   --     <info><facebook><id>...</id></facebook></info>
   --  </xxx>
   --  Person_Mapper.Add_Mapping ("@id");
   Person_Mapping.Bind (Get_Person_Member'Access);
   Person_Mapping.Add_Mapping ("address", Address_Mapping'Access, Proxy_Address'Access);
   Person_Mapping.Add_Mapping ("name", FIELD_FIRST_NAME);
   Person_Mapping.Add_Default_Mapping;
  --   Person_Mapper.Add_Mapping ("info/*");
   --  Person_Mapper.Add_Mapping ("address/street/@number");

   Person_Vector_Mapping.Set_Mapping ("person", Person_Mapping);
end Mapping;

Update samples with new mapper

Update samples with new mapper


-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 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 ASF.Events.Faces.Actions;

with ADO.Utils;
with ADO.Sessions.Entities;
with ADO.Sessions;
with ADO.Queries;
with ADO.Datasets;

with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;
package body AWA.Workspaces.Beans is

   package ASC renames AWA.Services.Contexts;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Load;

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Accept_Invitation;

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Send;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Action;

   --  ------------------------------
   --  Event action called to create the workspace when the given event is posted.
   --  ------------------------------
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Bean, Event);

      WS  : AWA.Workspaces.Models.Workspace_Ref;
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      AWA.Workspaces.Modules.Get_Workspace (Session   => DB,
                                            Context   => Ctx,
                                            Workspace => WS);
      Ctx.Commit;
   end Create;

   package Action_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Workspaces_Bean,
                                                      Method => Action,
                                                      Name   => "action");

   package Create_Binding is
      new AWA.Events.Action_Method.Bind (Name   => "create",
                                         Bean   => Workspaces_Bean,
                                         Method => Create);

   Workspaces_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Action_Binding.Proxy'Access, Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "count" then
         From.Count := Util.Beans.Objects.To_Integer (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Workspaces_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Workspaces_Bean_Access := new Workspaces_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Workspaces_Bean;

   --  ------------------------------
   --  Load the list of members.
   --  ------------------------------
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      User        : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session     : ADO.Sessions.Session := Into.Module.Get_Session;
      Query       : ADO.Queries.Context;
      Count_Query : ADO.Queries.Context;
      First       : constant Natural  := (Into.Page - 1) * Into.Page_Size;
   begin
      Query.Set_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
      Count_Query.Set_Count_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "page_table",
--                                          Table   => AWA.Wikis.Models.WIKI_PAGE_TABLE,
--                                          Session => Session);
      Query.Bind_Param (Name => "user_id", Value => User);
      Count_Query.Bind_Param (Name => "user_id", Value => User);
      AWA.Workspaces.Models.List (Into.Members, Session, Query);
      Into.Count := ADO.Datasets.Get_Count (Session, Count_Query);
   end Load;

end AWA.Workspaces.Beans;

-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 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 ASF.Events.Faces.Actions;

with ADO.Utils;
with ADO.Sessions.Entities;
with ADO.Sessions;
with ADO.Queries;
with ADO.Datasets;

with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;
package body AWA.Workspaces.Beans is

   package ASC renames AWA.Services.Contexts;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Load;

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Accept_Invitation;

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Send;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Action;

   --  ------------------------------
   --  Event action called to create the workspace when the given event is posted.
   --  ------------------------------
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Bean, Event);

      WS  : AWA.Workspaces.Models.Workspace_Ref;
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      AWA.Workspaces.Modules.Get_Workspace (Session   => DB,
                                            Context   => Ctx,
                                            Workspace => WS);
      Ctx.Commit;
   end Create;

   package Action_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Workspaces_Bean,
                                                      Method => Action,
                                                      Name   => "action");

   package Create_Binding is
      new AWA.Events.Action_Method.Bind (Name   => "create",
                                         Bean   => Workspaces_Bean,
                                         Method => Create);

   Workspaces_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Action_Binding.Proxy'Access, Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "count" then
         From.Count := Util.Beans.Objects.To_Integer (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Workspaces_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Workspaces_Bean_Access := new Workspaces_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Workspaces_Bean;

   --  ------------------------------
   --  Load the list of members.
   --  ------------------------------
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      User        : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session     : ADO.Sessions.Session := Into.Module.Get_Session;
      Query       : ADO.Queries.Context;
      Count_Query : ADO.Queries.Context;
      First       : constant Natural  := (Into.Page - 1) * Into.Page_Size;
   begin
      Query.Set_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
      Count_Query.Set_Count_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "page_table",
--                                          Table   => AWA.Wikis.Models.WIKI_PAGE_TABLE,
--                                          Session => Session);
      Query.Bind_Param (Name => "user_id", Value => User);
      Count_Query.Bind_Param (Name => "user_id", Value => User);
      AWA.Workspaces.Models.List (Into.Members, Session, Query);
      Into.Count := ADO.Datasets.Get_Count (Session, Count_Query);
   end Load;

   --  ------------------------------
   --  Create the Member_List_Bean bean instance.
   --  ------------------------------
   function Create_Member_List_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Member_List_Bean_Access := new Member_List_Bean;
   begin
      Object.Module     := Module;
      Object.Members_Bean := Object.Members'Access;
      Object.Page_Size  := 20;
      Object.Page       := 1;
      Object.Count      := 0;
      return Object.all'Access;
   end Create_Member_List_Bean;

end AWA.Workspaces.Beans;

Implement the Create_Member_List_Bean function


-----------------------------------------------------------------------
--  Util.Concurrent -- Concurrent Counters
--  Copyright (C) 2009, 2010 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.
-----------------------------------------------------------------------

--  The Counters package defines the Counter type which provides
--  atomic increment and decrement operations.  It is intended to be used to
--  implement reference counting in a multi-threaded environment.
--
--    type Ref is record
--        Cnt  : Counter;
--        Data : ...;
--    end record;
--
--    Object  : access Ref;
--    Is_Last : Boolean;
--  begin
--    Decrement (Object.Cnt, Is_Last);  -- Multi-task safe operation
--    if Is_Last then
--        Free (Object);
--    end if;
--
--  Unlike the Ada portable implementation based on protected type, this implementation
--  does not require that Counter be a limited type.
private with Interfaces;
package Util.Concurrent.Counters is

   pragma Preelaborate;

   --  ------------------------------
   --  Atomic Counter
   --  ------------------------------
   --  The atomic Counter implements a simple counter that can be
   --  incremented or decremented atomically.
   type Counter is private;
   type Counter_Access is access all Counter;

   --  Increment the counter atomically.
   procedure Increment (C : in out Counter);
   pragma Inline_Always (Increment);

   --  Increment the counter atomically and return the value before increment.
   procedure Increment (C     : in out Counter;
                        Value : out Integer);
   pragma Inline_Always (Increment);

   --  Decrement the counter atomically.
   procedure Decrement (C : in out Counter);
   pragma Inline_Always (Decrement);

   --  Decrement the counter atomically and return a status.
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean);
   pragma Inline_Always (Decrement);

   --  Get the counter value
   function Value (C : in Counter) return Integer;
   pragma Inline_Always (Value);

   ONE : constant Counter;

private

   --  This implementation works without an Ada protected type:
   --  o The size of the target object is 10 times smaller.
   --  o Increment and Decrement operations are 5 times faster.
   --  o It works by using special instructions
   type Counter is record
      Value : Interfaces.Unsigned_32 := 0;
   end record;

   ONE : constant Counter := Counter '(Value => 1);

end Util.Concurrent.Counters;

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

--  The Counters package defines the Counter type which provides
--  atomic increment and decrement operations.  It is intended to be used to
--  implement reference counting in a multi-threaded environment.
--
--    type Ref is record
--        Cnt  : Counter;
--        Data : ...;
--    end record;
--
--    Object  : access Ref;
--    Is_Last : Boolean;
--  begin
--    Decrement (Object.Cnt, Is_Last);  -- Multi-task safe operation
--    if Is_Last then
--        Free (Object);
--    end if;
--
--  Unlike the Ada portable implementation based on protected type, this implementation
--  does not require that Counter be a limited type.
private with Interfaces;
package Util.Concurrent.Counters is

   pragma Preelaborate;

   --  ------------------------------
   --  Atomic Counter
   --  ------------------------------
   --  The atomic Counter implements a simple counter that can be
   --  incremented or decremented atomically.
   type Counter is private;
   type Counter_Access is access all Counter;

   --  Increment the counter atomically.
   procedure Increment (C : in out Counter);
   pragma Inline_Always (Increment);

   --  Increment the counter atomically and return the value before increment.
   procedure Increment (C     : in out Counter;
                        Value : out Integer);
   pragma Inline_Always (Increment);

   --  Decrement the counter atomically.
   procedure Decrement (C : in out Counter);
   pragma Inline_Always (Decrement);

   --  Decrement the counter atomically and return a status.
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean);
   pragma Inline_Always (Decrement);

   --  Get the counter value
   function Value (C : in Counter) return Integer;
   pragma Inline_Always (Value);

   ONE : constant Counter;

private

   --  This implementation works without an Ada protected type:
   --  o The size of the target object is 10 times smaller.
   --  o Increment and Decrement operations are 5 times faster.
   --  o It works by using special instructions
   --  o The counter is Atomic to make sure the compiler will use atomic read/write instructions
   --    and it prevents optimization (Atomic implies Volatile).  The Atomic does not mean
   --    that atomic instructions are used.
   type Counter is record
      Value : Interfaces.Unsigned_32 := 0;
      pragma Atomic (Value);
   end record;

   ONE : constant Counter := Counter '(Value => 1);

end Util.Concurrent.Counters;

Declare the counter as Atomic to prevent compiler optimisation on the access of its value


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

with Ada.Calendar;
with Ada.Strings.Unbounded;
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with ASF.Views.Nodes;
with ASF.Contexts.Facelets;
with ASF.Factory;
with ASF.Components.Base;
with Ada.Finalization;

--  The ASF.Views.Facelets package contains the facelet factory
--  responsible for getting the facelet tree from a facelet name.
--  The facelets (or *.xhtml) files are loaded by the reader to form
--  a tag node tree which is cached by the factory.  The facelet factory
--  is shared by multiple requests and threads.
package ASF.Views.Facelets is

   type Facelet is private;
   type Facelet_Access is access all Facelet;

   --  Returns True if the facelet is null/empty.
   function Is_Null (F : Facelet) return Boolean;

   --  ------------------------------
   --  Facelet factory
   --  ------------------------------
   --  The facelet factory allows to retrieve the node tree to build the
   --  component tree.  The node tree can be shared by several component trees.
   --  The node tree is initialized from the XHTML view file.  It is put
   --  in a cache to avoid loading and parsing the file several times.
   type Facelet_Factory is limited private;

   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet);

   --  Create the component tree from the facelet view.
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.Base.UIComponent_Access);

   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Components          : access ASF.Factory.Component_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean);

   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   function Find_Facelet_Path (Factory : in Facelet_Factory;
                               Name    : in String) return String;

   --  Clear the facelet cache
   procedure Clear_Cache (Factory : in out Facelet_Factory);

private

   use Ada.Strings.Unbounded;

   type Facelet is record
      Root        : ASF.Views.Nodes.Tag_Node_Access;
      File        : ASF.Views.File_Info_Access;
      Modify_Time : Ada.Calendar.Time;
   end record;

   --  Tag library map indexed on the library namespace.
   package Facelet_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Facelet,
                                 Hash            => Ada.Strings.Unbounded.Hash,
                                 Equivalent_Keys => "=");

   use Facelet_Maps;

   protected type Facelet_Cache is
      --  Find the facelet entry associated with the given name.
      function Find (Name : in Unbounded_String) return Facelet;

      --  Insert or replace the facelet entry associated with the given name.
      procedure Insert (Name : in Unbounded_String;
                        Item : in Facelet);

      --  Clear the cache.
      procedure Clear;
   private
      Map     : Facelet_Maps.Map;
   end Facelet_Cache;

   type Facelet_Factory is new Ada.Finalization.Limited_Controlled with record
      Paths    : Unbounded_String := To_Unbounded_String ("");

      --  The facelet cache.
      Map      : Facelet_Cache;

      --  The component factory
      Factory  : access ASF.Factory.Component_Factory;

      --  Whether the unknown tags are escaped using XML escape rules.
      Escape_Unknown_Tags : Boolean := True;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   --  Free the storage held by the factory cache.
   overriding
   procedure Finalize (Factory : in out Facelet_Factory);

end ASF.Views.Facelets;

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

with Ada.Calendar;
with Ada.Strings.Unbounded;
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with ASF.Views.Nodes;
with ASF.Contexts.Facelets;
with ASF.Factory;
with ASF.Components.Base;
with Ada.Finalization;

--  The ASF.Views.Facelets package contains the facelet factory
--  responsible for getting the facelet tree from a facelet name.
--  The facelets (or *.xhtml) files are loaded by the reader to form
--  a tag node tree which is cached by the factory.  The facelet factory
--  is shared by multiple requests and threads.
package ASF.Views.Facelets is

   type Facelet is private;
   type Facelet_Access is access all Facelet;

   --  Returns True if the facelet is null/empty.
   function Is_Null (F : Facelet) return Boolean;

   --  ------------------------------
   --  Facelet factory
   --  ------------------------------
   --  The facelet factory allows to retrieve the node tree to build the
   --  component tree.  The node tree can be shared by several component trees.
   --  The node tree is initialized from the XHTML view file.  It is put
   --  in a cache to avoid loading and parsing the file several times.
   type Facelet_Factory is limited private;

   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet);

   --  Create the component tree from the facelet view.
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.Base.UIComponent_Access);

   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Components          : access ASF.Factory.Component_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean);

   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   function Find_Facelet_Path (Factory : in Facelet_Factory;
                               Name    : in String) return String;

   --  Clear the facelet cache
   procedure Clear_Cache (Factory : in out Facelet_Factory);

private

   use Ada.Strings.Unbounded;

   type Facelet is record
      Root        : ASF.Views.Nodes.Tag_Node_Access;
      File        : ASF.Views.File_Info_Access;
      Modify_Time : Ada.Calendar.Time;
   end record;

   Empty : constant Facelet := (others => <>);

   --  Tag library map indexed on the library namespace.
   package Facelet_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Facelet,
                                 Hash            => Ada.Strings.Unbounded.Hash,
                                 Equivalent_Keys => "=");

   use Facelet_Maps;

   protected type Facelet_Cache is
      --  Find the facelet entry associated with the given name.
      function Find (Name : in Unbounded_String) return Facelet;

      --  Insert or replace the facelet entry associated with the given name.
      procedure Insert (Name : in Unbounded_String;
                        Item : in Facelet);

      --  Clear the cache.
      procedure Clear;
   private
      Map     : Facelet_Maps.Map;
   end Facelet_Cache;

   type Facelet_Factory is new Ada.Finalization.Limited_Controlled with record
      Paths    : Unbounded_String := To_Unbounded_String ("");

      --  The facelet cache.
      Map      : Facelet_Cache;

      --  The component factory
      Factory  : access ASF.Factory.Component_Factory;

      --  Whether the unknown tags are escaped using XML escape rules.
      Escape_Unknown_Tags : Boolean := True;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   --  Free the storage held by the factory cache.
   overriding
   procedure Finalize (Factory : in out Facelet_Factory);

end ASF.Views.Facelets;

Declare the Empty constant to represent an empty facelet


-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  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.
-----------------------------------------------------------------------
with Ada.Calendar;
with Ada.Strings.Unbounded;

with Util.Log.Loggers;
with Util.Serialize.IO.XML;
with Util.Properties;
with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Tools;

with AWA.Services.Contexts;
with AWA.Users.Models;

with ADO;
with ADO.Queries;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Events.Queues.Persistents is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Queues.Persistents");

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

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   overriding
   function Get_Queue (From : in Persistent_Queue) return AWA.Events.Models.Queue_Ref is
   begin
      return From.Queue;
   end Get_Queue;

   --  ------------------------------
   --  Queue the event.  The event is saved in the database with a relation to
   --  the user, the user session, the event queue and the event type.
   --  ------------------------------
   overriding
   procedure Enqueue (Into  : in out Persistent_Queue;
                      Event : in AWA.Events.Module_Event'Class) is
      use Ada.Strings.Unbounded;
      use Util.Streams;
      procedure Add_Property (Name, Value : in Util.Properties.Value);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Msg   : AWA.Events.Models.Message_Ref;

      Has_Param : Boolean := False;
      Output    : Util.Serialize.IO.XML.Output_Stream;

      procedure Add_Property (Name, Value : in Util.Properties.Value) is
      begin
         if not Has_Param then
            Output.Initialize (Size => 10000);
            Has_Param := True;
            Output.Start_Entity (Name => "params");
         end if;
         Output.Start_Entity (Name => "param");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_String (Value => To_String (Value));
         Output.End_Entity (Name => "param");
      end Add_Property;

   begin
      Ctx.Start;
      Msg.Set_Queue (Into.Queue);
      Msg.Set_User (Ctx.Get_User);
      Msg.Set_Session (Ctx.Get_User_Session);
      Msg.Set_Create_Date (Event.Get_Time);
      Msg.Set_Status (AWA.Events.Models.QUEUED);

      --  Collect the event parameters in a string and format the result in XML.
      --  If there is no parameter, avoid the overhead of allocating and formatting this.
      Event.Props.Iterate (Process => Add_Property'Access);
      if Has_Param then
         Output.End_Entity (Name => "params");
         Msg.Set_Parameters (Util.Streams.Texts.To_String (Buffered.Buffered_Stream (Output)));
      end if;

--        Msg.Set_Message_Type
      Msg.Save (DB);
      Ctx.Commit;

      Log.Info ("Event {0} created", ADO.Identifier'Image (Msg.Get_Id));
   end Enqueue;

   overriding
   procedure Dequeue (From : in out Persistent_Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Ctx      : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB       : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Messages : Models.Message_Vector;
      Query    : ADO.Queries.Context;
      Task_Id  : Integer := 0;

      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      procedure Prepare_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSING);
         Msg.Set_Server_Id (From.Server_Id);
         Msg.Set_Task_Id (Task_Id);
         Msg.Set_Processing_Date (ADO.Nullable_Time '(Is_Null => False,
                                                      Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Prepare_Message;

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref) is
         User    : constant AWA.Users.Models.User_Ref'Class := Msg.Get_User;
         Session : constant AWA.Users.Models.Session_Ref'Class := Msg.Get_Session;
         Event   : Module_Event;
      begin

         Process (Event);
      end Dispatch_Message;

      --  Finish processing the message by marking it as being processed.
      procedure Finish_Message (Msg : in out Models.Message_Ref) is
      begin
         Ctx.Start;
         Msg.Set_Status (Models.PROCESSED);
         Msg.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                  Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
         Ctx.Commit;
      end Finish_Message;

      Count : Natural;
   begin
      Ctx.Start;
      Query.Set_Query (Models.Query_Queue_Pending_Message);
      Query.Bind_Param ("queue", From.Queue.Get_Id);
      Query.Bind_Param ("max", From.Max_Batch);
      Models.List (Messages, DB, Query);
      Count := Natural (Messages.Length);

      --  Prepare the event messages by marking them in the database.
      --  This makes sure that no other server or task (if any), will process them.
      if Count > 0 then
         for I in 1 .. Count loop
            Messages.Update_Element (Index   => I,
                                     Process => Prepare_Message'Access);
         end loop;
      end if;
      Ctx.Commit;

      if Count = 0 then
         return;
      end if;

      --  Dispatch each event.
      for I in 1 .. Count loop
         Messages.Update_Element (Index   => I,
                                  Process => Dispatch_Message'Access);
      end loop;

      --  After having dispatched the events, mark them as dispatched in the queue.
      Ctx.Start;
      for I in 1 .. Count loop
         Messages.Update_Element (Index   => I,
                                  Process => Finish_Message'Access);
      end loop;
      Ctx.Commit;
   end Dequeue;

   --  ------------------------------
   --  Create the queue associated with the given name and configure it by using
   --  the configuration properties.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class) return Queue_Access is
      package AC renames AWA.Services.Contexts;

      Ctx     : constant AC.Service_Context_Access := AC.Current;
      Session : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Queue   : AWA.Events.Models.Queue_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      Session.Begin_Transaction;
      --  Find the queue instance which matches the name.
      Query.Set_Filter ("o.name = ?");
      Query.Add_Param (Name);
      Queue.Find (Session => Session,
                  Query   => Query,
                  Found   => Found);

      --  But create the queue instance if it does not exist.
      if not Found then
         Queue.Set_Name (Name);
         Queue.Save (Session);
      end if;
      Session.Commit;
      declare
         Result : constant Persistent_Queue_Access
           := new Persistent_Queue '(Name_Length  => Name'Length,
                                     Name         => Name,
                                     Queue        => Queue,
                                     others       => <>);
      begin
         return Result.all'Access;
      end;
   end Create_Queue;

end AWA.Events.Queues.Persistents;

-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  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.
-----------------------------------------------------------------------
with Ada.Calendar;
with Ada.Strings.Unbounded;

with Util.Log.Loggers;
with Util.Serialize.IO.XML;
with Util.Properties;
with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Tools;

with AWA.Services.Contexts;
with AWA.Users.Models;

with ADO;
with ADO.Queries;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Events.Queues.Persistents is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Queues.Persistents");

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

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   overriding
   function Get_Queue (From : in Persistent_Queue) return AWA.Events.Models.Queue_Ref is
   begin
      return From.Queue;
   end Get_Queue;

   --  ------------------------------
   --  Queue the event.  The event is saved in the database with a relation to
   --  the user, the user session, the event queue and the event type.
   --  ------------------------------
   overriding
   procedure Enqueue (Into  : in out Persistent_Queue;
                      Event : in AWA.Events.Module_Event'Class) is
      use Ada.Strings.Unbounded;
      use Util.Streams;
      procedure Add_Property (Name, Value : in Util.Properties.Value);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Msg   : AWA.Events.Models.Message_Ref;

      Has_Param : Boolean := False;
      Output    : Util.Serialize.IO.XML.Output_Stream;

      procedure Add_Property (Name, Value : in Util.Properties.Value) is
      begin
         if not Has_Param then
            Output.Initialize (Size => 10000);
            Has_Param := True;
            Output.Start_Entity (Name => "params");
         end if;
         Output.Start_Entity (Name => "param");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_String (Value => To_String (Value));
         Output.End_Entity (Name => "param");
      end Add_Property;

   begin
      Ctx.Start;
      Msg.Set_Queue (Into.Queue);
      Msg.Set_User (Ctx.Get_User);
      Msg.Set_Session (Ctx.Get_User_Session);
      Msg.Set_Create_Date (Event.Get_Time);
      Msg.Set_Status (AWA.Events.Models.QUEUED);

      --  Collect the event parameters in a string and format the result in XML.
      --  If there is no parameter, avoid the overhead of allocating and formatting this.
      Event.Props.Iterate (Process => Add_Property'Access);
      if Has_Param then
         Output.End_Entity (Name => "params");
         Msg.Set_Parameters (Util.Streams.Texts.To_String (Buffered.Buffered_Stream (Output)));
      end if;

--        Msg.Set_Message_Type
      Msg.Save (DB);
      Ctx.Commit;

      Log.Info ("Event {0} created", ADO.Identifier'Image (Msg.Get_Id));
   end Enqueue;

   overriding
   procedure Dequeue (From : in out Persistent_Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Ctx      : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB       : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Messages : Models.Message_Vector;
      Query    : ADO.Queries.Context;
      Task_Id  : Integer := 0;

      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      procedure Prepare_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSING);
         Msg.Set_Server_Id (From.Server_Id);
         Msg.Set_Task_Id (Task_Id);
         Msg.Set_Processing_Date (ADO.Nullable_Time '(Is_Null => False,
                                                      Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Prepare_Message;

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref) is
         User    : constant AWA.Users.Models.User_Ref'Class := Msg.Get_User;
         Session : constant AWA.Users.Models.Session_Ref'Class := Msg.Get_Session;
         Event   : Module_Event;
      begin

         Process (Event);
      end Dispatch_Message;

      --  Finish processing the message by marking it as being processed.
      procedure Finish_Message (Msg : in out Models.Message_Ref) is
      begin
         Ctx.Start;
         Msg.Set_Status (Models.PROCESSED);
         Msg.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                  Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
         Ctx.Commit;
      end Finish_Message;

      Count : Natural;
   begin
      Ctx.Start;
      Query.Set_Query (Models.Query_Queue_Pending_Message);
      Query.Bind_Param ("queue", From.Queue.Get_Id);
      Query.Bind_Param ("max", From.Max_Batch);
      Models.List (Messages, DB, Query);
      Count := Natural (Messages.Length);

      --  Prepare the event messages by marking them in the database.
      --  This makes sure that no other server or task (if any), will process them.
      if Count > 0 then
         for I in 1 .. Count loop
            Messages.Update_Element (Index   => I,
                                     Process => Prepare_Message'Access);
         end loop;
      end if;
      Ctx.Commit;

      if Count = 0 then
         return;
      end if;

      --  Dispatch each event.
      for I in 1 .. Count loop
         Messages.Update_Element (Index   => I,
                                  Process => Dispatch_Message'Access);
      end loop;

      --  After having dispatched the events, mark them as dispatched in the queue.
      Ctx.Start;
      for I in 1 .. Count loop
         Messages.Update_Element (Index   => I,
                                  Process => Finish_Message'Access);
      end loop;
      Ctx.Commit;
   end Dequeue;

   --  ------------------------------
   --  Create the queue associated with the given name and configure it by using
   --  the configuration properties.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class) return Queue_Access is
      package AC renames AWA.Services.Contexts;

      Ctx     : constant AC.Service_Context_Access := AC.Current;
      Session : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Queue   : AWA.Events.Models.Queue_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      Session.Begin_Transaction;
      --  Find the queue instance which matches the name.
      Query.Set_Filter ("o.name = ?");
      Query.Add_Param (Name);
      Queue.Find (Session => Session,
                  Query   => Query,
                  Found   => Found);

      --  But create the queue instance if it does not exist.
      if not Found then
         Log.Info ("Creating database queue {0}", Name);
         Queue.Set_Name (Name);
         Queue.Save (Session);
      else
         Log.Info ("Using database queue {0}", Name);
      end if;
      Session.Commit;
      declare
         Result : constant Persistent_Queue_Access
           := new Persistent_Queue '(Name_Length  => Name'Length,
                                     Name         => Name,
                                     Queue        => Queue,
                                     others       => <>);
      begin
         return Result.all'Access;
      end;
   end Create_Queue;

end AWA.Events.Queues.Persistents;

Add some log to report when an event queue is created in the database


-----------------------------------------------------------------------
--  util-stacks -- Simple stack
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
generic
   type Element_Type is private;
   type Element_Type_Access is access all Element_Type;
package Util.Stacks is

   type Stack is limited private;

   --  Get access to the current stack element.
   function Current (Container : in Stack) return Element_Type_Access;

   --  Push an element on top of the stack making the new element the current one.
   procedure Push (Container : in out Stack);

   --  Pop the top element.
   procedure Pop (Container : in out Stack);

   --  Clear the stack.
   procedure Clear (Container : in out Stack);

private
   type Element_Type_Array is array (Natural range <>) of aliased Element_Type;
   type Element_Type_Array_Access is access all Element_Type_Array;

   type Stack is new Ada.Finalization.Limited_Controlled with record
      Current : Element_Type_Access := null;
      Stack   : Element_Type_Array_Access := null;
      Pos     : Natural := 0;
   end record;

   --  Release the stack
   overriding
   procedure Finalize (Obj : in out Stack);

end Util.Stacks;

-----------------------------------------------------------------------
--  util-stacks -- Simple stack
--  Copyright (C) 2010, 2011, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
generic
   type Element_Type is private;
   type Element_Type_Access is access all Element_Type;
package Util.Stacks is

   pragma Preelaborate;

   type Stack is limited private;

   --  Get access to the current stack element.
   function Current (Container : in Stack) return Element_Type_Access;

   --  Push an element on top of the stack making the new element the current one.
   procedure Push (Container : in out Stack);

   --  Pop the top element.
   procedure Pop (Container : in out Stack);

   --  Clear the stack.
   procedure Clear (Container : in out Stack);

private
   type Element_Type_Array is array (Natural range <>) of aliased Element_Type;
   type Element_Type_Array_Access is access all Element_Type_Array;

   type Stack is new Ada.Finalization.Limited_Controlled with record
      Current : Element_Type_Access := null;
      Stack   : Element_Type_Array_Access := null;
      Pos     : Natural := 0;
   end record;

   --  Release the stack
   overriding
   procedure Finalize (Obj : in out Stack);

end Util.Stacks;

Make the package Preelaborate

Make the package Preelaborate


-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  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 Ada.Strings.Unbounded;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols;
      Console : MAT.Consoles.Console_Access;
   end record;

   type Target_Type_Access is access all Target_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

   --
--  private
--
--     type Target_Type is tagged limited record
--        Memory : MAT.Memory.Targets.Target_Memory;
--     end record;

end MAT.Targets;

-----------------------------------------------------------------------
--  mat-targets - Representation of target information
--  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 Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Maps;

with MAT.Types;
with MAT.Memory.Targets;
with MAT.Symbols.Targets;
with MAT.Readers;
with MAT.Consoles;
package MAT.Targets is

   type Target_Process_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Console : MAT.Consoles.Console_Access;
   end record;
   type Target_Process_Type_Access is access all Target_Process_Type'Class;

   type Target_Type is tagged limited record
      Pid     : MAT.Types.Target_Process_Ref;
      Memory  : MAT.Memory.Targets.Target_Memory;
      Symbols : MAT.Symbols.Targets.Target_Symbols;
      Console : MAT.Consoles.Console_Access;
   end record;

   type Target_Type_Access is access all Target_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class);

private

   --  Define a map of <tt>Target_Process_Type_Access</tt> keyed by the process Id.
   --  This map allows to retrieve the information about a process.
   use type MAT.Types.Target_Process_Ref;
   package Process_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Process_Ref,
                                      Element_Type => Target_Process_Type_Access);

end MAT.Targets;

Declare the Process_Maps package

Declare the Process_Maps package


-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 2013, 2015, 2016, 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 body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;
      use Ada.Calendar.Formatting;

      Result : Date_Record;
      Pos    : Natural;
      pragma Unreferenced (Pos);
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Hour       := 0;
      Result.Minute     := 0;
      Result.Second     := 0;
      Result.Sub_Second := 0.0;
      Result.Time_Zone  := 0;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

         --  ISO8601 date: YYYY-MM-DDTHH
         if Date'Length > 12 then
            if Date (Date'First + 10) /= 'T' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Hour := Hour_Number'Value (Date (Date'First + 11 .. Date'First + 12));
            Pos := Date'First + 13;
         end if;
         if Date'Length > 15 then
            if Date (Date'First + 13) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Minute := Minute_Number'Value (Date (Date'First + 14 .. Date'First + 15));
            Pos := Date'First + 16;
         end if;
         if Date'Length > 18 then
            if Date (Date'First + 16) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Second := Second_Number'Value (Date (Date'First + 17 .. Date'First + 18));
            Pos := Date'First + 19;
         end if;

         --  ISO8601 timezone: +hh:mm or -hh:mm
--           if Date'Length > Pos + 4 then
--              if Date (Pos) /= '+' and Date (Pos) /= '-' and Date (Pos + 2) /= ':' then
--                 raise Constraint_Error with "invalid date";
--              end if;
--           end if;
      else
         raise Constraint_Error with "invalid date";
      end if;
      return Time_Of (Result);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D, Precision);
   end Image;

   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String is
      use type Ada.Calendar.Time_Zones.Time_Offset;

      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 29) := "0000-00-00T00:00:00.000-00:00";
      N,  Tz  : Natural;
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      if Precision = YEAR then
         return Result (1 .. 4);
      end if;
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      if Precision = MONTH then
         return Result (1 .. 7);
      end if;
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      if Precision = DAY then
         return Result (1 .. 10);
      end if;
      Result (12) := To_Char (Date.Hour / 10);
      Result (13) := To_Char (Date.Hour mod 10);
      if Precision = HOUR then
         return Result (1 .. 13);
      end if;
      Result (15) := To_Char (Date.Minute / 10);
      Result (16) := To_Char (Date.Minute mod 10);
      if Precision = MINUTE then
         return Result (1 .. 16);
      end if;
      Result (18) := To_Char (Date.Second / 10);
      Result (19) := To_Char (Date.Second mod 10);
      if Precision = SECOND then
         return Result (1 .. 19);
      end if;
      N := Natural (Date.Sub_Second * 1000.0);
      Result (21) := To_Char (N / 100);
      Result (22) := To_Char ((N mod 100) / 10);
      Result (23) := To_Char (N mod 10);
      if Date.Time_Zone < 0 then
         Tz := Natural (-Date.Time_Zone);
      else
         Result (24) := '+';
         Tz := Natural (Date.Time_Zone);
      end if;
      Result (25) := To_Char (Tz / 600);
      Result (26) := To_Char ((Tz / 60) mod 10);
      Tz := Tz mod 60;
      Result (28) := To_Char (Tz / 10);
      Result (29) := To_Char (Tz mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

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

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;
      use Ada.Calendar.Formatting;
      use Ada.Calendar.Time_Zones;

      Result : Date_Record;
      Pos    : Natural;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Hour       := 0;
      Result.Minute     := 0;
      Result.Second     := 0;
      Result.Sub_Second := 0.0;
      Result.Time_Zone  := 0;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

         --  ISO8601 date: YYYY-MM-DDTHH
         if Date'Length > 12 then
            if Date (Date'First + 10) /= 'T' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Hour := Hour_Number'Value (Date (Date'First + 11 .. Date'First + 12));
            Pos := Date'First + 13;
         end if;
         if Date'Length > 15 then
            if Date (Date'First + 13) /= ':' then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Minute := Minute_Number'Value (Date (Date'First + 14 .. Date'First + 15));
            Pos := Date'First + 16;
         end if;
         if Date'Length >= 17 then
            if Date (Date'First + 16) /= ':' or else Date'Length <= 18 then
               raise Constraint_Error with "invalid date";
            end if;
            Result.Second := Second_Number'Value (Date (Date'First + 17 .. Date'First + 18));
            Pos := Date'First + 19;
            if Pos <= Date'Last then
               if Date (Pos) = '.' or Date (Pos) = ',' then
                  if Date'Length < 22 then
                     raise Constraint_Error with "invalid date";
                  end if;
                  declare
                     Value : constant Natural := Natural'Value (Date (Pos + 1 .. Pos + 3));
                  begin
                     Result.Sub_Second := Second_Duration (Duration (Value) / 1000.0);
                  end;
                  Pos := Pos + 4;
               end if;
               if Pos <= Date'Last then
                  --  ISO8601 timezone: Z
                  --  ISO8601 timezone: +hh or -hh
                  --  ISO8601 timezone: +hhmm or -hhmm
                  --  ISO8601 timezone: +hh:mm or -hh:mm
                  if Date (Pos) = 'Z' then
                     if Pos /= Date'Last then
                        raise Constraint_Error with "invalid date";
                     end if;
                  elsif Date (Pos) /= '-' and Date (Pos) /= '+' then
                     raise Constraint_Error with "invalid date";

                  elsif Pos + 2 = Date'Last then
                     Result.Time_Zone := 60 * Time_Offset'Value (Date (Pos + 1 .. Date'Last));

                  elsif Pos + 4 = Date'Last then
                     Result.Time_Zone := 60 * Time_Offset'Value (Date (Pos + 1 .. Pos + 2))
                       + Time_Offset'Value (Date (Pos + 3 .. Date'Last));

                  elsif Pos + 5 = Date'Last and then Date (Pos + 3) = ':' then
                     Result.Time_Zone := 60 * Time_Offset'Value (Date (Pos + 1 .. Pos + 2))
                       + Time_Offset'Value (Date (Pos + 4 .. Date'Last));

                  else
                     raise Constraint_Error with "invalid date";
                  end if;
               end if;
            end if;
         end if;
      else
         raise Constraint_Error with "invalid date";
      end if;
      return Time_Of (Result);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D, Precision);
   end Image;

   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String is
      use type Ada.Calendar.Time_Zones.Time_Offset;

      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 29) := "0000-00-00T00:00:00.000-00:00";
      N,  Tz  : Natural;
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      if Precision = YEAR then
         return Result (1 .. 4);
      end if;
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      if Precision = MONTH then
         return Result (1 .. 7);
      end if;
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      if Precision = DAY then
         return Result (1 .. 10);
      end if;
      Result (12) := To_Char (Date.Hour / 10);
      Result (13) := To_Char (Date.Hour mod 10);
      if Precision = HOUR then
         return Result (1 .. 13);
      end if;
      Result (15) := To_Char (Date.Minute / 10);
      Result (16) := To_Char (Date.Minute mod 10);
      if Precision = MINUTE then
         return Result (1 .. 16);
      end if;
      Result (18) := To_Char (Date.Second / 10);
      Result (19) := To_Char (Date.Second mod 10);
      if Precision = SECOND then
         return Result (1 .. 19);
      end if;
      N := Natural (Date.Sub_Second * 1000.0);
      Result (21) := To_Char (N / 100);
      Result (22) := To_Char ((N mod 100) / 10);
      Result (23) := To_Char (N mod 10);
      if Date.Time_Zone < 0 then
         Tz := Natural (-Date.Time_Zone);
      else
         Result (24) := '+';
         Tz := Natural (Date.Time_Zone);
      end if;
      Result (25) := To_Char (Tz / 600);
      Result (26) := To_Char ((Tz / 60) mod 10);
      Tz := Tz mod 60;
      Result (28) := To_Char (Tz / 10);
      Result (29) := To_Char (Tz mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

Add support to parse sub-seconds and timezone