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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------

   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------

   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Fix compilation

Fix compilation


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

with Util.Test_Caller;
with Util.Measures;
with Util.Strings.Transforms;
with Ada.Text_IO;
with Util.Encoders.SHA1;
with Util.Encoders.SHA256;
with Util.Encoders.HMAC.SHA1;
with Util.Encoders.HMAC.SHA256;
with Util.Encoders.Base16;
with Util.Encoders.Base64;
with Util.Encoders.AES;
with Util.Encoders.KDF.PBKDF2;
package body Util.Encoders.KDF.Tests is

   use Util.Tests;

   procedure PBKDF2_HMAC_SHA256 is
     new KDF.PBKDF2 (Length => Util.Encoders.SHA256.HASH_SIZE,
                     Hash   => Util.Encoders.HMAC.SHA256.Sign);

   procedure PBKDF2_HMAC_SHA1 is
     new KDF.PBKDF2 (Length => Util.Encoders.SHA1.HASH_SIZE,
                     Hash   => Util.Encoders.HMAC.SHA1.Sign);

   package Caller is new Util.Test_Caller (Test, "Encoders.KDF");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.KDF.PBKDF2.HMAC_SHA1",
                       Test_PBKDF2_HMAC_SHA1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.KDF.PBKDF2.HMAC_SHA256",
                       Test_PBKDF2_HMAC_SHA256'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test derived key generation with HMAC-SHA1.
   --  ------------------------------
   procedure Test_PBKDF2_HMAC_SHA1 (T : in out Test) is
      Pass : Secret_Key := Create (Password => "password");
      Salt : Secret_Key := Create (Password => "salt");
      Key  : Secret_Key (Length => 20);
      B    : Util.Encoders.Base64.Encoder;
      Hex  : Util.Encoders.Base16.Encoder;
   begin
      --  RFC6070 - test vector 1
      PBKDF2_HMAC_SHA1 (Pass, Salt, 1, Key);

      Util.Tests.Assert_Equals (T, "0C60C80F961F0E71F3A9B524AF6012062FE037A6",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 1");

      --  RFC6070 - test vector 2
      PBKDF2_HMAC_SHA1 (Pass, Salt, 2, Key);

      Util.Tests.Assert_Equals (T, "EA6C014DC72D6F8CCD1ED92ACE1D41F0D8DE8957",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 2");

      --  RFC6070 - test vector 3
      PBKDF2_HMAC_SHA1 (Pass, Salt, 4096, Key);

      Util.Tests.Assert_Equals (T, "4B007901B765489ABEAD49D926F721D065A429C1",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 3");
   end Test_PBKDF2_HMAC_SHA1;

   --  ------------------------------
   --  Test derived key generation with HMAC-SHA1.
   --  ------------------------------
   procedure Test_PBKDF2_HMAC_SHA256 (T : in out Test) is
      Pass : Secret_Key := Create (Password => "password");
      Salt : Secret_Key := Create (Password => "salt");
      Key  : Secret_Key (Length => 32);
      B    : Util.Encoders.Base64.Encoder;
      Hex  : Util.Encoders.Base16.Encoder;
   begin
      --  RFC6070 - test vector 1
      PBKDF2_HMAC_SHA256 (Pass, Salt, 1, Key);

      Util.Tests.Assert_Equals (T, "120FB6CFFCF8B32C43E7225256C4F837A8"
                                & "6548C92CCC35480805987CB70BE17B",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 1");

      --  RFC6070 - test vector 2
      PBKDF2_HMAC_SHA256 (Pass, Salt, 2, Key);

      Util.Tests.Assert_Equals (T, "AE4D0C95AF6B46D32D0ADFF928F06DD02A"
                                & "303F8EF3C251DFD6E2D85A95474C43",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 2");

      --  RFC6070 - test vector 3
      PBKDF2_HMAC_SHA256 (Pass, Salt, 4096, Key);

      Util.Tests.Assert_Equals (T, "C5E478D59288C841AA530DB6845C4C8D96"
                                & "2893A001CE4E11A4963873AA98134A",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 3");
   end Test_PBKDF2_HMAC_SHA256;

end Util.Encoders.KDF.Tests;

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

with Util.Test_Caller;
with Util.Encoders.SHA1;
with Util.Encoders.SHA256;
with Util.Encoders.HMAC.SHA1;
with Util.Encoders.HMAC.SHA256;
with Util.Encoders.Base16;
with Util.Encoders.AES;
with Util.Encoders.KDF.PBKDF2;
package body Util.Encoders.KDF.Tests is

   procedure PBKDF2_HMAC_SHA256 is
     new KDF.PBKDF2 (Length => Util.Encoders.SHA256.HASH_SIZE,
                     Hash   => Util.Encoders.HMAC.SHA256.Sign);

   procedure PBKDF2_HMAC_SHA1 is
     new KDF.PBKDF2 (Length => Util.Encoders.SHA1.HASH_SIZE,
                     Hash   => Util.Encoders.HMAC.SHA1.Sign);

   package Caller is new Util.Test_Caller (Test, "Encoders.KDF");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.KDF.PBKDF2.HMAC_SHA1",
                       Test_PBKDF2_HMAC_SHA1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.KDF.PBKDF2.HMAC_SHA256",
                       Test_PBKDF2_HMAC_SHA256'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test derived key generation with HMAC-SHA1.
   --  ------------------------------
   procedure Test_PBKDF2_HMAC_SHA1 (T : in out Test) is
      Pass : Secret_Key := Create (Password => "password");
      Salt : Secret_Key := Create (Password => "salt");
      Key  : Secret_Key (Length => 20);
      Hex  : Util.Encoders.Base16.Encoder;
   begin
      --  RFC6070 - test vector 1
      PBKDF2_HMAC_SHA1 (Pass, Salt, 1, Key);

      Util.Tests.Assert_Equals (T, "0C60C80F961F0E71F3A9B524AF6012062FE037A6",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 1");

      --  RFC6070 - test vector 2
      PBKDF2_HMAC_SHA1 (Pass, Salt, 2, Key);

      Util.Tests.Assert_Equals (T, "EA6C014DC72D6F8CCD1ED92ACE1D41F0D8DE8957",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 2");

      --  RFC6070 - test vector 3
      PBKDF2_HMAC_SHA1 (Pass, Salt, 4096, Key);

      Util.Tests.Assert_Equals (T, "4B007901B765489ABEAD49D926F721D065A429C1",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA1 test vector 3");
   end Test_PBKDF2_HMAC_SHA1;

   --  ------------------------------
   --  Test derived key generation with HMAC-SHA1.
   --  ------------------------------
   procedure Test_PBKDF2_HMAC_SHA256 (T : in out Test) is
      Pass : Secret_Key := Create (Password => "password");
      Salt : Secret_Key := Create (Password => "salt");
      Key  : Secret_Key (Length => 32);
      Hex  : Util.Encoders.Base16.Encoder;
   begin
      --  RFC6070 - test vector 1
      PBKDF2_HMAC_SHA256 (Pass, Salt, 1, Key);

      Util.Tests.Assert_Equals (T, "120FB6CFFCF8B32C43E7225256C4F837A8"
                                & "6548C92CCC35480805987CB70BE17B",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 1");

      --  RFC6070 - test vector 2
      PBKDF2_HMAC_SHA256 (Pass, Salt, 2, Key);

      Util.Tests.Assert_Equals (T, "AE4D0C95AF6B46D32D0ADFF928F06DD02A"
                                & "303F8EF3C251DFD6E2D85A95474C43",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 2");

      --  RFC6070 - test vector 3
      PBKDF2_HMAC_SHA256 (Pass, Salt, 4096, Key);

      Util.Tests.Assert_Equals (T, "C5E478D59288C841AA530DB6845C4C8D96"
                                & "2893A001CE4E11A4963873AA98134A",
                                Hex.Transform (Key.Secret),
                                "PBKDF2-HMAC-SHA256 test vector 3");
   end Test_PBKDF2_HMAC_SHA256;

end Util.Encoders.KDF.Tests;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  bkp-stores-local -- Store management for local 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.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Strings.Unbounded;
with Ada.Streams.Stream_IO;
with Interfaces.C.Strings;
with System.OS_Constants;

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;
package body Babel.Stores.Local is

   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

end Babel.Stores.Local;

-----------------------------------------------------------------------
--  bkp-stores-local -- Store management for local 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.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Strings.Unbounded;
with Ada.Streams.Stream_IO;
with Interfaces.C.Strings;
with System.OS_Constants;

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;

with Babel.Streams.Files;
package body Babel.Stores.Local is

   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   --  ------------------------------
   --  Open a file in the store to read its content with a stream.
   --  ------------------------------
   overriding
   procedure Read_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Refs.Stream_Ref) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Buffer : Babel.Files.Buffers.Buffer_Access;
   begin
      Log.Info ("Read file {0}", Path);

      Stream := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      Store.Pool.Get_Buffer (Buffer);
      File.Open (Path, Buffer);
   end Read_File;

   --  ------------------------------
   --  Write a file in the store with a stream.
   --  ------------------------------
   overriding
   procedure Write_File (Store  : in out Local_Store_Type;
                         Path   : in String;
                         Stream : in Babel.Streams.Refs.Stream_Ref;
                         Mode   : in Util.Systems.Types.mode_t) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Output : Babel.Streams.Refs.Stream_Ref;
   begin
      Log.Info ("Write file {0}", Path);

      Output := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      File.Create (Path, Mode);
      Babel.Streams.Refs.Copy (From => Stream,
                               Into => Output);
   end Write_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

   --  ------------------------------
   --  Set the buffer pool to be used by local store.
   --  ------------------------------
   procedure Set_Buffers (Store   : in out Local_Store_Type;
                          Buffers : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Store.Pool := Buffers;
   end Set_Buffers;

end Babel.Stores.Local;

Implement the Read_File, Write_File and Set_Buffers procedures


-----------------------------------------------------------------------
--  Util.Concurrent.Fifos -- Concurrent Fifo 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.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

-----------------------------------------------------------------------
--  Util.Concurrent.Fifos -- Concurrent Fifo Queues
--  Copyright (C) 2012, 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.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Fix compilation warning reported by gcc 4.7


-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 2015, 2016, 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 Ada.Strings.Unbounded;
with Ada.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Dates.ISO8601;

package body Util.Serialize.IO.CSV is

   --  ------------------------------
   --  Set the field separator.  The default field separator is the comma (',').
   --  ------------------------------
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character) is
   begin
      Stream.Separator := Separator;
   end Set_Field_Separator;

   --  ------------------------------
   --  Enable or disable the double quotes by default for strings.
   --  ------------------------------
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean) is
   begin
      Stream.Quote := Enable;
   end Set_Quotes;

   --  ------------------------------
   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   --  ------------------------------
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
      for I in Value'Range loop
         if Value (I) = '"' then
            Stream.Write ("""""");
         else
            Stream.Write (Value (I));
         end if;
      end loop;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      Stream.Write (Util.Strings.Image (Value));
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Value then
         Stream.Write ("true");
      else
         Stream.Write ("false");
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Stream.Quote then
               Stream.Write ("""null""");
            else
               Stream.Write ("null");
            end if;

         when TYPE_BOOLEAN =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            --  Stream.Write ('"');
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));
            --  Stream.Write ('"');

         when others =>
            Stream.Write_Cell (Util.Beans.Objects.To_String (Value));

      end case;
   end Write_Cell;

   --  ------------------------------
   --  Start a new row.
   --  ------------------------------
   procedure New_Row (Stream : in out Output_Stream) is
   begin
      while Stream.Column < Stream.Max_Columns loop
         Stream.Write (Stream.Separator);
         Stream.Column := Stream.Column + 1;
      end loop;
      Stream.Write (ASCII.CR);
      Stream.Write (ASCII.LF);
      Stream.Column := 1;
      Stream.Row := Stream.Row + 1;
   end New_Row;

   --  -----------------------
   --  Write the attribute name/value pair.
   --  -----------------------
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   --  -----------------------
   --  Write the entity value.
   --  -----------------------
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is
   begin
      Stream.Write_Entity (Name, Util.Dates.ISO8601.Image (Value, Util.Dates.ISO8601.SUBSECOND));
   end Write_Entity;

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is
   begin
      null;
   end Write_Long_Entity;

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is
   begin
      Stream.Write_Entity (Name, Value);
   end Write_Enum_Entity;

   --  ------------------------------
   --  Write the attribute with a null value.
   --  ------------------------------
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String) is
   begin
      Stream.Write_Entity (Name, "");
   end Write_Null_Attribute;

   --  ------------------------------
   --  Write an entity with a null value.
   --  ------------------------------
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String) is
   begin
      Stream.Write_Null_Attribute (Name);
   end Write_Null_Entity;

   --  ------------------------------
   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   --  ------------------------------
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String is
      use type Ada.Containers.Count_Type;

      Default_Header : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
      Result : String (1 .. 10);
      N, R   : Natural;
      Pos    : Positive := Result'Last;
   begin
      if Handler.Headers.Length >= Ada.Containers.Count_Type (Column) then
         return Handler.Headers.Element (Positive (Column));
      end if;
      N := Natural (Column - 1);
      loop
         R := N mod 26;
         N := N / 26;
         Result (Pos) := Default_Header (R + 1);
         exit when N = 0;
         Pos := Pos - 1;
      end loop;
      return Result (Pos .. Result'Last);
   end Get_Header_Name;

   --  ------------------------------
   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   --  ------------------------------
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type) is
      use Ada.Containers;
   begin
      if Row = 0 then
         --  Build the headers table.
         declare
            Missing : constant Integer := Integer (Column) - Integer (Handler.Headers.Length);
         begin
            if Missing > 0 then
               Handler.Headers.Set_Length (Handler.Headers.Length + Count_Type (Missing));
            end if;
            Handler.Headers.Replace_Element (Positive (Column), Value);
         end;
      else
         declare
            Name : constant String := Handler.Get_Header_Name (Column);
         begin
            --  Detect a new row.  Close the current object and start a new one.
            if Handler.Row /= Row then
               if Row > 1 then
                  Handler.Sink.Finish_Object ("", Handler);
               else
                  Handler.Sink.Start_Array ("", Handler);
               end if;
               Handler.Sink.Start_Object ("", Handler);
            end if;
            Handler.Row := Row;
            Handler.Sink.Set_Member (Name, Util.Beans.Objects.To_Object (Value), Handler);
         end;
      end if;
   end Set_Cell;

   --  ------------------------------
   --  Set the field separator.  The default field separator is the comma (',').
   --  ------------------------------
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character) is
   begin
      Handler.Separator := Separator;
   end Set_Field_Separator;

   --  ------------------------------
   --  Get the field separator.
   --  ------------------------------
   function Get_Field_Separator (Handler : in Parser) return Character is
   begin
      return Handler.Separator;
   end Get_Field_Separator;

   --  ------------------------------
   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   --  ------------------------------
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character) is
   begin
      Handler.Comment := Separator;
   end Set_Comment_Separator;

   --  ------------------------------
   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   --  ------------------------------
   function Get_Comment_Separator (Handler : in Parser) return Character is
   begin
      return Handler.Comment;
   end Get_Comment_Separator;

   --  ------------------------------
   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   --  ------------------------------
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True) is
   begin
      Handler.Use_Default_Headers := Mode;
   end Set_Default_Headers;

   --  ------------------------------
   --  Parse the stream using the CSV parser.
   --  Call Set_Cell for each cell that has been parsed indicating the row and
   --  column numbers as well as the cell value.
   --  ------------------------------
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class) is
      use Ada.Strings.Unbounded;

      C              : Character;
      Token          : Unbounded_String;
      Column         : Column_Type := 1;
      Row            : Row_Type  := 0;
      In_Quote_Token : Boolean := False;
      In_Escape      : Boolean := False;
      Ignore_Row     : Boolean := False;
   begin
      if Handler.Use_Default_Headers then
         Row := 1;
      end if;
      Handler.Headers.Clear;
      Handler.Sink := Sink'Unchecked_Access;
      loop
         Stream.Read (Char => C);

         if C = Ada.Characters.Latin_1.CR  or C = Ada.Characters.Latin_1.LF then
            if C = Ada.Characters.Latin_1.LF then
               Handler.Line_Number := Handler.Line_Number + 1;
            end if;
            if not Ignore_Row then
               if In_Quote_Token and not In_Escape then
                  Append (Token, C);

               elsif Column > 1 or else Length (Token) > 0 then
                  Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
                  Set_Unbounded_String (Token, "");
                  Row            := Row + 1;
                  Column         := 1;
                  In_Quote_Token := False;
                  In_Escape      := False;
               end if;
            else
               Ignore_Row := False;
            end if;

         elsif C = Handler.Separator and not Ignore_Row then
            if In_Quote_Token and not In_Escape then
               Append (Token, C);

            else
               Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
               Set_Unbounded_String (Token, "");
               Column         := Column + 1;
               In_Quote_Token := False;
               In_Escape      := False;
            end if;

         elsif C = '"' and not Ignore_Row then
            if In_Quote_Token then
               In_Escape := True;

            elsif In_Escape then
               Append (Token, C);
               In_Escape := False;

            elsif Ada.Strings.Unbounded.Length (Token) = 0 then
               In_Quote_Token := True;

            else
               Append (Token, C);
            end if;

         elsif C = Handler.Comment and Handler.Comment /= ASCII.NUL
           and Column = 1 and Length (Token) = 0
         then
            Ignore_Row := True;

         elsif not Ignore_Row then
            Append (Token, C);
            In_Escape := False;

         end if;

      end loop;

   exception
      when Ada.IO_Exceptions.Data_Error =>
         Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
         Handler.Sink := null;
         return;
   end Parse;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   overriding
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

end Util.Serialize.IO.CSV;

-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 2015, 2016, 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 Ada.Strings.Unbounded;
with Ada.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Dates.ISO8601;

package body Util.Serialize.IO.CSV is

   --  ------------------------------
   --  Set the field separator.  The default field separator is the comma (',').
   --  ------------------------------
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character) is
   begin
      Stream.Separator := Separator;
   end Set_Field_Separator;

   --  ------------------------------
   --  Enable or disable the double quotes by default for strings.
   --  ------------------------------
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean) is
   begin
      Stream.Quote := Enable;
   end Set_Quotes;

   --  ------------------------------
   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   --  ------------------------------
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
      for I in Value'Range loop
         if Value (I) = '"' then
            Stream.Write ("""""");
         else
            Stream.Write (Value (I));
         end if;
      end loop;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      Stream.Write (Util.Strings.Image (Value));
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Value then
         Stream.Write ("true");
      else
         Stream.Write ("false");
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Stream.Quote then
               Stream.Write ("""null""");
            else
               Stream.Write ("null");
            end if;

         when TYPE_BOOLEAN =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            --  Stream.Write ('"');
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));
            --  Stream.Write ('"');

         when others =>
            Stream.Write_Cell (Util.Beans.Objects.To_String (Value));

      end case;
   end Write_Cell;

   --  ------------------------------
   --  Start a new row.
   --  ------------------------------
   procedure New_Row (Stream : in out Output_Stream) is
   begin
      while Stream.Column < Stream.Max_Columns loop
         Stream.Write (Stream.Separator);
         Stream.Column := Stream.Column + 1;
      end loop;
      Stream.Write (ASCII.CR);
      Stream.Write (ASCII.LF);
      Stream.Column := 1;
      Stream.Row := Stream.Row + 1;
   end New_Row;

   --  -----------------------
   --  Write the attribute name/value pair.
   --  -----------------------
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   --  -----------------------
   --  Write the entity value.
   --  -----------------------
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is
   begin
      Stream.Write_Entity (Name, Util.Dates.ISO8601.Image (Value, Util.Dates.ISO8601.SUBSECOND));
   end Write_Entity;

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is
   begin
      null;
   end Write_Long_Entity;

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is
   begin
      Stream.Write_Entity (Name, Value);
   end Write_Enum_Entity;

   --  ------------------------------
   --  Write the attribute with a null value.
   --  ------------------------------
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String) is
   begin
      Stream.Write_Entity (Name, "");
   end Write_Null_Attribute;

   --  ------------------------------
   --  Write an entity with a null value.
   --  ------------------------------
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String) is
   begin
      Stream.Write_Null_Attribute (Name);
   end Write_Null_Entity;

   --  ------------------------------
   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   --  ------------------------------
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String is
      use type Ada.Containers.Count_Type;

      Default_Header : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
      Result : String (1 .. 10);
      N, R   : Natural;
      Pos    : Positive := Result'Last;
   begin
      if Handler.Headers.Length >= Ada.Containers.Count_Type (Column) then
         return Handler.Headers.Element (Positive (Column));
      end if;
      N := Natural (Column - 1);
      loop
         R := N mod 26;
         N := N / 26;
         Result (Pos) := Default_Header (R + 1);
         exit when N = 0;
         Pos := Pos - 1;
      end loop;
      return Result (Pos .. Result'Last);
   end Get_Header_Name;

   --  ------------------------------
   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   --  ------------------------------
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type) is
      use Ada.Containers;
   begin
      if Row = 0 then
         --  Build the headers table.
         declare
            Missing : constant Integer := Integer (Column) - Integer (Handler.Headers.Length);
         begin
            if Missing > 0 then
               Handler.Headers.Set_Length (Handler.Headers.Length + Count_Type (Missing));
            end if;
            Handler.Headers.Replace_Element (Positive (Column), Value);
         end;
      else
         declare
            Name : constant String := Handler.Get_Header_Name (Column);
         begin
            --  Detect a new row.  Close the current object and start a new one.
            if Handler.Row /= Row then
               if Row > 1 then
                  Handler.Sink.Finish_Object ("", Handler);
               else
                  Handler.Sink.Start_Array ("", Handler);
               end if;
               Handler.Sink.Start_Object ("", Handler);
            end if;
            Handler.Row := Row;
            Handler.Sink.Set_Member (Name, Util.Beans.Objects.To_Object (Value), Handler);
         end;
      end if;
   end Set_Cell;

   --  ------------------------------
   --  Set the field separator.  The default field separator is the comma (',').
   --  ------------------------------
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character) is
   begin
      Handler.Separator := Separator;
   end Set_Field_Separator;

   --  ------------------------------
   --  Get the field separator.
   --  ------------------------------
   function Get_Field_Separator (Handler : in Parser) return Character is
   begin
      return Handler.Separator;
   end Get_Field_Separator;

   --  ------------------------------
   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   --  ------------------------------
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character) is
   begin
      Handler.Comment := Separator;
   end Set_Comment_Separator;

   --  ------------------------------
   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   --  ------------------------------
   function Get_Comment_Separator (Handler : in Parser) return Character is
   begin
      return Handler.Comment;
   end Get_Comment_Separator;

   --  ------------------------------
   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   --  ------------------------------
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True) is
   begin
      Handler.Use_Default_Headers := Mode;
   end Set_Default_Headers;

   --  ------------------------------
   --  Parse the stream using the CSV parser.
   --  Call Set_Cell for each cell that has been parsed indicating the row and
   --  column numbers as well as the cell value.
   --  ------------------------------
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Input_Buffer_Stream'Class;
                    Sink    : in out Reader'Class) is
      use Ada.Strings.Unbounded;

      C              : Character;
      Token          : Unbounded_String;
      Column         : Column_Type := 1;
      Row            : Row_Type  := 0;
      In_Quote_Token : Boolean := False;
      In_Escape      : Boolean := False;
      Ignore_Row     : Boolean := False;
   begin
      if Handler.Use_Default_Headers then
         Row := 1;
      end if;
      Handler.Headers.Clear;
      Handler.Sink := Sink'Unchecked_Access;
      loop
         Stream.Read (Char => C);

         if C = Ada.Characters.Latin_1.CR  or C = Ada.Characters.Latin_1.LF then
            if C = Ada.Characters.Latin_1.LF then
               Handler.Line_Number := Handler.Line_Number + 1;
            end if;
            if not Ignore_Row then
               if In_Quote_Token and not In_Escape then
                  Append (Token, C);

               elsif Column > 1 or else Length (Token) > 0 then
                  Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
                  Set_Unbounded_String (Token, "");
                  Row            := Row + 1;
                  Column         := 1;
                  In_Quote_Token := False;
                  In_Escape      := False;
               end if;
            else
               Ignore_Row := False;
            end if;

         elsif C = Handler.Separator and not Ignore_Row then
            if In_Quote_Token and not In_Escape then
               Append (Token, C);

            else
               Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
               Set_Unbounded_String (Token, "");
               Column         := Column + 1;
               In_Quote_Token := False;
               In_Escape      := False;
            end if;

         elsif C = '"' and not Ignore_Row then
            if In_Quote_Token then
               In_Escape := True;

            elsif In_Escape then
               Append (Token, C);
               In_Escape := False;

            elsif Ada.Strings.Unbounded.Length (Token) = 0 then
               In_Quote_Token := True;

            else
               Append (Token, C);
            end if;

         elsif C = Handler.Comment and Handler.Comment /= ASCII.NUL
           and Column = 1 and Length (Token) = 0
         then
            Ignore_Row := True;

         elsif not Ignore_Row then
            Append (Token, C);
            In_Escape := False;

         end if;

      end loop;

   exception
      when Ada.IO_Exceptions.Data_Error =>
         Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
         Handler.Sink := null;
         return;
   end Parse;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   overriding
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

end Util.Serialize.IO.CSV;

Use the Input_Buffer_Stream instead of Buffered_Stream