-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 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;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value);

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value);

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value));

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access);

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Object.Impl.Count := 1;
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      else
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
         Object.Impl.Count := 1;
      end if;
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Bundle.Impl.Count := Bundle.Impl.Count + 1;
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in Value)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      --  ------------------------------
      --  Returns the property value.  Raises an exception if not found.
      --  ------------------------------
      function Get (Self : in Manager; Name : in Value)
                   return Value is
      begin
         return Self.Props.Get (Name);

      exception
         when NO_PROPERTY =>
            declare
               Iter : Cursor := Self.List.First;
            begin
               while Has_Element (Iter) loop
                  begin
                     return Element (Iter).all.Get (Name);
                  exception
                     when NO_PROPERTY =>
                        Iter := Next (Iter);
                  end;
               end loop;
            end;
            raise;
      end Get;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      procedure Insert (Self : in out Manager;
                        Name : in Value;
                        Item : in Value) is
         pragma Unreferenced (Self);
         pragma Unreferenced (Name);
         pragma Unreferenced (Item);
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Insert;

      --  ------------------------------
      --  Set the value of the property.  The property is created if it
      --  does not exists.
      --  ------------------------------
      procedure Set (Self : in out Manager;
                     Name : in Value;
                     Item : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access) is
         pragma Unreferenced (Self);
         Item : Manager_Object_Access := Manager (Obj.all)'Access;
      begin
         Free (Item);
      end Delete;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter   : constant Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 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;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value);

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value);

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value));

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access);

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl = null then
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      end if;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Util.Concurrent.Counters.Increment (Bundle.Impl.Count);
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in Value)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      --  ------------------------------
      --  Returns the property value.  Raises an exception if not found.
      --  ------------------------------
      function Get (Self : in Manager; Name : in Value)
                   return Value is
      begin
         return Self.Props.Get (Name);

      exception
         when NO_PROPERTY =>
            declare
               Iter : Cursor := Self.List.First;
            begin
               while Has_Element (Iter) loop
                  begin
                     return Element (Iter).all.Get (Name);
                  exception
                     when NO_PROPERTY =>
                        Iter := Next (Iter);
                  end;
               end loop;
            end;
            raise;
      end Get;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      procedure Insert (Self : in out Manager;
                        Name : in Value;
                        Item : in Value) is
         pragma Unreferenced (Self);
         pragma Unreferenced (Name);
         pragma Unreferenced (Item);
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Insert;

      --  ------------------------------
      --  Set the value of the property.  The property is created if it
      --  does not exists.
      --  ------------------------------
      procedure Set (Self : in out Manager;
                     Name : in Value;
                     Item : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access) is
         pragma Unreferenced (Self);
         Item : Manager_Object_Access := Manager (Obj.all)'Access;
      begin
         Free (Item);
      end Delete;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter   : constant Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

Update to use the concurrent counters

Update to use the concurrent counters


-----------------------------------------------------------------------
--  util-serialize-contexts -- Contexts for serialization framework
--  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.Unchecked_Deallocation;
with Util.Concurrent.Locks;
package body Util.Serialize.Contexts is

   procedure Free is new Ada.Unchecked_Deallocation (Data'Class, Data_Access);

   --  ------------------------------
   --  Context data key
   --  ------------------------------

   Lock     : Util.Concurrent.Locks.RW_Lock;
   Next_Key : Data_Key := 1;

   --  ------------------------------
   --  Allocate a unique data key for a mapper.
   --  ------------------------------
   procedure Allocate (Key : out Data_Key) is
   begin
      Lock.Write;
      Key := Next_Key;
      Next_Key := Next_Key + 1;
      Lock.Release_Write;
   end Allocate;

   function Hash (Key : in Data_Key) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Reader context
   --  ------------------------------

   --  ------------------------------
   --  Get the data object associated with the given key.
   --  Raises No_Data exception if there is no data object.
   --  ------------------------------
   function Get_Data (Ctx : in Context;
                      Key : in Data_Key) return Data_Access is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         return Data_Map.Element (Pos);
      else
         raise No_Data;
      end if;
   end Get_Data;

   --  ------------------------------
   --  Set the data object associated with the given key.
   --  ------------------------------
   procedure Set_Data (Ctx     : in out Context;
                       Key     : in Data_Key;
                       Content : in Data_Access) is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         declare
            Old : Data_Access := Data_Map.Element (Pos);
         begin
            if Old = Content then
               return;
            end if;
            Free (Old);
         end;
         Ctx.Data.Replace_Element (Position => Pos, New_Item => Content);
      else
         Ctx.Data.Insert (Key => Key, New_Item => Content);
      end if;
   end Set_Data;

   --  ------------------------------
   --  Free the context data.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Context) is
      Pos     : Data_Map.Cursor;
      Content : Data_Access;
   begin
      loop
         Pos := Ctx.Data.First;
         exit when not Data_Map.Has_Element (Pos);
         Content := Data_Map.Element (Pos);
         Free (Content);
         Ctx.Data.Delete (Pos);
      end loop;
   end Finalize;

end Util.Serialize.Contexts;

-----------------------------------------------------------------------
--  util-serialize-contexts -- Contexts for serialization framework
--  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.Unchecked_Deallocation;
with Util.Concurrent.Counters;
package body Util.Serialize.Contexts is

   procedure Free is new Ada.Unchecked_Deallocation (Data'Class, Data_Access);

   --  ------------------------------
   --  Context data key
   --  ------------------------------
   Next_Key : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;

   --  ------------------------------
   --  Allocate a unique data key for a mapper.
   --  ------------------------------
   procedure Allocate (Key : out Data_Key) is
      Val : Integer;
   begin
      Util.Concurrent.Counters.Increment (Next_Key, Val);
      Key := Data_Key (Val);
   end Allocate;

   function Hash (Key : in Data_Key) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Reader context
   --  ------------------------------

   --  ------------------------------
   --  Get the data object associated with the given key.
   --  Raises No_Data exception if there is no data object.
   --  ------------------------------
   function Get_Data (Ctx : in Context;
                      Key : in Data_Key) return Data_Access is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         return Data_Map.Element (Pos);
      else
         raise No_Data;
      end if;
   end Get_Data;

   --  ------------------------------
   --  Set the data object associated with the given key.
   --  ------------------------------
   procedure Set_Data (Ctx     : in out Context;
                       Key     : in Data_Key;
                       Content : in Data_Access) is
      Pos : constant Data_Map.Cursor := Ctx.Data.Find (Key);
   begin
      if Data_Map.Has_Element (Pos) then
         declare
            Old : Data_Access := Data_Map.Element (Pos);
         begin
            if Old = Content then
               return;
            end if;
            Free (Old);
         end;
         Ctx.Data.Replace_Element (Position => Pos, New_Item => Content);
      else
         Ctx.Data.Insert (Key => Key, New_Item => Content);
      end if;
   end Set_Data;

   --  ------------------------------
   --  Free the context data.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Context) is
      Pos     : Data_Map.Cursor;
      Content : Data_Access;
   begin
      loop
         Pos := Ctx.Data.First;
         exit when not Data_Map.Has_Element (Pos);
         Content := Data_Map.Element (Pos);
         Free (Content);
         Ctx.Data.Delete (Pos);
      end loop;
   end Finalize;

end Util.Serialize.Contexts;

Use the atomic increment and get counter operation instead of a RW lock


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

   use Ada.Strings.Unbounded;
   use Ada.Text_IO;

   procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
   begin
      Gateway.Refresh;
      Put (To_String (Gateway.Ip));
      Set_Col (30);
      Put (Gateway.Wan.Get ("wan.internet.state", "?"));
      Set_Col (38);
      Put (Gateway.Wan.Get ("wan.ip.address", "?"));
      Set_Col (60);
      Put (Gateway.Device.Get ("device.numberofboots", "-"));
      Set_Col (68);
      Put (Gateway.Device.Get ("device.uptime", "-"));
      New_Line;
   end Box_Status;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Util.Commands.Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Druss.Gateways.Iterate (Context.Gateways, Box_Status'Access);
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
   begin
      Put_Line ("bbox: Operations to control the bbox");
      Put_Line ("Usage: druss bbox list");
      Put_Line ("       druss bbox add IP");
      Put_Line ("       druss bbox del IP");
   end Help;

end Druss.Commands.Bboxes;

-----------------------------------------------------------------------
--  druss-commands-bboxes -- Commands to manage the bboxes
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Streams;
with Util.Log.Loggers;
with Util.Properties;
with Util.Strings;
with Util.Strings.Sets;
with Bbox.API;
with Druss.Gateways;
with UPnP.SSDP;
package body Druss.Commands.Bboxes is

   use Ada.Strings.Unbounded;
   use Ada.Text_IO;
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Druss.Commands.Bboxes");

   procedure Discover (IP : in String) is
      Box  : Bbox.API.Client_Type;
      Info : Util.Properties.Manager;
   begin
      Box.Set_Server (IP);
      Box.Get ("device", Info);
      if Info.Get ("device.modelname", "") /= "" then
         Log.Info ("Found a bbox at {0}", IP);
      end if;

   exception
      when E : others =>
         null;
   end Discover;

   procedure Discover (Command   : in Command_Type) is
      IPs          : Util.Strings.Sets.Set;
      Retry        : Natural := 0;
      Scanner      : UPnP.SSDP.Scanner_Type;
      Itf_IPs      : Util.Strings.Sets.Set;

      procedure Process (URI : in String) is
         Pos2 : Natural;
      begin
         --  http://
         Pos2 := Util.Strings.Index (URI, ':', 7);
         if Pos2 > 0 and then not IPs.Contains (URI (URI'First + 7 .. Pos2 - 1)) then
            Log.Info ("Detected an IGD device at {0}", URI (URI'First + 7 .. Pos2 - 1));
            IPs.Include (URI (URI'First + 7 .. Pos2 - 1));
         end if;
         Log.Warn ("Found: {0}", URI);
      end Process;

   begin
      Log.Info ("Discovering gateways on the network");

      Scanner.Initialize;
      Scanner.Find_IPv4_Addresses (Itf_IPs);
      while Retry < 5 loop
         Scanner.Send_Discovery ("urn:schemas-upnp-org:device:InternetGatewayDevice:1", Itf_IPs);
         Scanner.Discover ("urn:schemas-upnp-org:device:InternetGatewayDevice:1",
                           Process'Access, 1.0);
         Retry := Retry + 1;
      end loop;

      for IP of IPs loop
         Discover (IP);
      end loop;
   end Discover;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Util.Commands.Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      if Args.Get_Count = 0 then
         Druss.Commands.Driver.Usage (Args);
      elsif Args.Get_Argument (1) = "discover" then
         Command.Discover;
      end if;
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
   begin
      Put_Line ("bbox: Manage and define the configuration to connect to the Bbox");
      Put_Line ("Usage: bbox <operation>...");
      New_Line;
      Put_Line ("  The Bbox API operation are called and the raw JSON result is printed.");
      Put_Line ("  When several operations are called, a JSON array is formed to insert");
      Put_Line ("  their result in the final JSON content so that it is valid.");
      Put_Line ("  Examples:");
      Put_Line ("    bbox discover          Discover the bbox(es) connected to the LAN");
      Put_Line ("    bbox add IP            Add a bbox Get information about the Bbox");
      Put_Line ("    bbox del IP            Get the list of hosts detected by the Bbox");
   end Help;

end Druss.Commands.Bboxes;

Implement the Discover procedure by using SSDP to discover the IGD devices and doing a Bbox API call


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

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Routes.Servlets;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Filters.Dump;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      use type ASF.Routes.Route_Type_Access;

      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Context.Get_Route /= null, "No mapping found for " & URI);

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "/home/test.jsf", "");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Filter_Mapping (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
      S2  : aliased Test_Servlet2;
      F1  : aliased ASF.Filters.Dump.Dump_Filter;
      F2  : aliased ASF.Filters.Dump.Dump_Filter;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
      Ctx.Add_Servlet ("Json", S2'Unchecked_Access);
      Ctx.Add_Filter ("Dump", F1'Unchecked_Access);
      Ctx.Add_Filter ("Dump2", F2'Unchecked_Access);
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.json", Name => "Json");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/file.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump2");
      Ctx.Start;
      T.Check_Mapping (Ctx, "test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "file.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/file.html", S1'Unchecked_Access, 1);
      T.Check_Mapping (Ctx, "/dump/result/test.html", S1'Unchecked_Access, 2);
      T.Check_Mapping (Ctx, "test.json", S2'Unchecked_Access);
   end Test_Filter_Mapping;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access;
                            Filter : in Natural := 0) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Filters.Filter_List_Access;

      Disp  : constant Request_Dispatcher := Ctx.Get_Request_Dispatcher (URI);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
      Servlet_Route : ASF.Routes.Servlets.Servlet_Route_Type_Access;
   begin
      if Server = null then
         T.Assert (Route = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Route /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class,
                   "The route is not a Servlet route");
         Servlet_Route := ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all)'Access;
         T.Assert (Servlet_Route.Servlet = Server,
                   "Invalid mapping returned for URI: " & URI);
         if Filter = 0 then
            T.Assert (Disp.Filters = null,
                      "Filters are configured for URI: " & URI);
         else
            T.Assert (Disp.Filters /= null, "No filter on the route URI: " & URI);
            Util.Tests.Assert_Equals (T, Filter, Disp.Filters'Length,
                                      "Invalid mapping returned for URI: " & URI);
         end if;
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      --  Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (extension)");
--        end;

--        T.Assert (Map /= null, "No mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (path)");
--        end;
--
--        T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Filter",
                       Test_Filter_Mapping'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

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

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Routes.Servlets;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Filters.Dump;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      use type ASF.Routes.Route_Type_Access;

      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Context.Get_Route /= null, "No mapping found for " & URI);

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "/home/test.jsf", "");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
      Check_Request (T, Ctx, "/root/home/test.jsf", "/root/home/test.jsf", "");
      Check_Request (T, Ctx, "/test.jsf", "/test.jsf", "");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Filter_Mapping (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
      S2  : aliased Test_Servlet2;
      F1  : aliased ASF.Filters.Dump.Dump_Filter;
      F2  : aliased ASF.Filters.Dump.Dump_Filter;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
      Ctx.Add_Servlet ("Json", S2'Unchecked_Access);
      Ctx.Add_Filter ("Dump", F1'Unchecked_Access);
      Ctx.Add_Filter ("Dump2", F2'Unchecked_Access);
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.json", Name => "Json");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/file.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump2");
      Ctx.Start;
      T.Check_Mapping (Ctx, "test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "file.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/file.html", S1'Unchecked_Access, 1);
      T.Check_Mapping (Ctx, "/dump/result/test.html", S1'Unchecked_Access, 2);
      T.Check_Mapping (Ctx, "test.json", S2'Unchecked_Access);
   end Test_Filter_Mapping;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access;
                            Filter : in Natural := 0) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Filters.Filter_List_Access;

      Disp  : constant Request_Dispatcher := Ctx.Get_Request_Dispatcher (URI);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
      Servlet_Route : ASF.Routes.Servlets.Servlet_Route_Type_Access;
   begin
      if Server = null then
         T.Assert (Route = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Route /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class,
                   "The route is not a Servlet route");
         Servlet_Route := ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all)'Access;
         T.Assert (Servlet_Route.Servlet = Server,
                   "Invalid mapping returned for URI: " & URI);
         if Filter = 0 then
            T.Assert (Disp.Filters = null,
                      "Filters are configured for URI: " & URI);
         else
            T.Assert (Disp.Filters /= null, "No filter on the route URI: " & URI);
            Util.Tests.Assert_Equals (T, Filter, Disp.Filters'Length,
                                      "Invalid mapping returned for URI: " & URI);
         end if;
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      --  Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (extension)");
--        end;

--        T.Assert (Map /= null, "No mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (path)");
--        end;
--
--        T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Filter",
                       Test_Filter_Mapping'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

Add more servlet mapping tests

Add more servlet mapping tests


-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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 Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with Ada.Exceptions;
with Ada.IO_Exceptions;
package body Util.Serialize.IO is

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);
   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Attribute (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Entity (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Entity;

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Buffer, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Stream, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;

   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

end Util.Serialize.IO;

-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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 Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with Ada.Exceptions;
with Ada.IO_Exceptions;
package body Util.Serialize.IO is

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);
   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Attribute (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Entity (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Entity;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String) is
   begin
      if Value.Is_Null then
         Stream.Write_Null_Entity (Name);
      else
         Stream.Write_Entity (Name, Value.Value);
      end if;
   end Write_Entity;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Time) is
   begin
      if Value.Is_Null then
         Stream.Write_Null_Entity (Name);
      else
         Stream.Write_Entity (Name, Value.Value);
      end if;
   end Write_Entity;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Boolean) is
   begin
      if Value.Is_Null then
         Stream.Write_Null_Entity (Name);
      else
         Stream.Write_Entity (Name, Value.Value);
      end if;
   end Write_Entity;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Integer) is
   begin
      if Value.Is_Null then
         Stream.Write_Null_Entity (Name);
      else
         Stream.Write_Entity (Name, Value.Value);
      end if;
   end Write_Entity;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Long) is
   begin
      if Value.Is_Null then
         Stream.Write_Null_Entity (Name);
      else
         Stream.Write_Entity (Name, Integer (Value.Value));
      end if;
   end Write_Entity;

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Buffer, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      Sink.Start_Document;
      Parser'Class (Handler).Parse (Stream, Sink);

   exception
--      when Util.Serialize.Mappers.Field_Fatal_Error =>
--         null;

      when E : others =>
         if not Handler.Error_Flag then
            Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
         end if;

   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

end Util.Serialize.IO;

Implement Write_Entity operations on several Nullable types