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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
package body Util.Properties.Bundles is

   use Util.Log;

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

      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;

      Path    : constant String := To_String (Factory.Path);
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Pattern : constant String := Name & "*.properties";
      Ent     : Directory_Entry_Type;
      Names   : Util.Strings.String_Set.Set;
      Search  : Search_Type;
   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Start_Search (Search, Directory => Path,
                    Pattern => Pattern, Filter => Filter);

      Factory.Lock.Write;

      begin
         --  Scan the directory and load all the property files.
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple      : constant String := Simple_Name (Ent);
               File_Path   : constant String := Full_Name (Ent);
               Bundle      : constant Bundle_Manager_Access := new Manager;
               Bundle_Name : constant Name_Access
                 := new String '(Simple (Simple'First .. Simple'Last - 11));
            begin
               Log.Debug ("Loading file {0}", File_Path);

               Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
               Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
               Found := True;
               Names.Insert (Bundle_Name);
            end;
         end loop;

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

      --  ------------------------------
      --  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 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;
with Util.Strings.Maps;
package body Util.Properties.Bundles is

   use Util.Log;

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

      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;

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

      procedure Process_File (Name      : in String;
                              File_Path : in String) is
         Bundle      : constant Bundle_Manager_Access := new Manager;
         Bundle_Name : constant Name_Access
           := new String '(Name (Name'First .. Name'Last - 11));
      begin
         Log.Debug ("Loading file {0}", File_Path);

         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
         Found := True;
         Names.Insert (Bundle_Name);
      end Process_File;

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

      Found := False;
      Util.Files.Find_Files_Path (Pattern => Pattern,
                                  Path    => Path,
                                  Into    => Files);

      Factory.Lock.Write;

      begin
         Iter := Files.First;
         while Util.Strings.Maps.Has_Element (Iter) loop
            Util.Strings.Maps.Query_Element (Iter, Process_File'Access);
            Util.Strings.Maps.Next (Iter);
         end loop;

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

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

Use Find_Files_Path to search the resource bundles in several directories


-----------------------------------------------------------------------
--  wiki-render-html -- Wiki HTML renderer
--  Copyright (C) 2011, 2012, 2013, 2015, 2016, 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 Wiki.Attributes;
with Wiki.Streams.Html;
with Wiki.Strings;
with Wiki.Render.Links;

--  == HTML Renderer ==
--  The <tt>Html_Renderer</tt> allows to render a wiki document into an HTML content.
--
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Engine : in out Html_Renderer;
                                Links  : in Wiki.Render.Links.Link_Renderer_Access);

   --  Set the render TOC flag that controls the TOC rendering.
   procedure Set_Render_TOC (Engine : in out Html_Renderer;
                             State  : in Boolean);

   --  Set the no-newline mode to avoid emitting newlines (disabled by default).
   procedure Set_No_Newline (Engine : in out Html_Renderer;
                             Enable : in Boolean);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Documents.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Get the current section number.
   function Get_Section_Number (Engine    : in Html_Renderer;
                                Prefix    : in Wiki.Strings.WString;
                                Separator : in Wiki.Strings.WChar) return Wiki.Strings.WString;

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Engine : in out Html_Renderer;
                             Level    : in Natural);

   --  Render a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Render_List_Item (Engine   : in out Html_Renderer;
                               Level    : in Positive;
                               Ordered  : in Boolean);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Html_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Wiki.Strings.WString);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Documents.Document);

private

   procedure Close_Paragraph (Engine : in out Html_Renderer);
   procedure Open_Paragraph (Engine : in out Html_Renderer);

   type Toc_Number_Array is array (1 .. 6) of Natural;

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Wiki.Render.Links.Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output            : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format            : Wiki.Format_Map := (others => False);
      Links             : Wiki.Render.Links.Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph     : Boolean := False;
      Need_Paragraph    : Boolean := False;
      Has_Item          : Boolean := False;
      Enable_Render_TOC : Boolean := False;
      TOC_Rendered      : Boolean := False;
      No_Newline        : Boolean := False;
      Current_Level     : Natural := 0;
      Html_Tag          : Wiki.Html_Tag := BODY_TAG;
      List_Styles       : List_Style_Array := (others => False);
      Quote_Level       : Natural := 0;
      Html_Level        : Natural := 0;
      Current_Section   : Toc_Number_Array := (others => 0);
      Section_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Documents.Document;
                         Node   : in Wiki.Nodes.Node_Type);

   --  Render a section header in the document.
   procedure Render_Header (Engine : in out Html_Renderer;
                            Doc    : in Wiki.Documents.Document;
                            Header : in Wiki.Strings.WString;
                            Level  : in Positive);

   --  Render the table of content.
   procedure Render_TOC (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Documents.Document;
                         Level  : in Natural);

   --  Render a link.
   procedure Render_Link (Engine : in out Html_Renderer;
                          Doc    : in Wiki.Documents.Document;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List);

   --  Render an image.
   procedure Render_Image (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Documents.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Documents.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List);

   --  Returns true if the HTML element being included is already contained in a paragraph.
   --  This include: a, em, strong, small, b, i, u, s, span, ins, del, sub, sup.
   function Has_Html_Paragraph (Engine : in Html_Renderer) return Boolean;

end Wiki.Render.Html;

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

--  == HTML Renderer ==
--  The <tt>Html_Renderer</tt> allows to render a wiki document into an HTML content.
--
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Engine : in out Html_Renderer;
                                Links  : in Wiki.Render.Links.Link_Renderer_Access);

   --  Set the render TOC flag that controls the TOC rendering.
   procedure Set_Render_TOC (Engine : in out Html_Renderer;
                             State  : in Boolean);

   --  Set the no-newline mode to avoid emitting newlines (disabled by default).
   procedure Set_No_Newline (Engine : in out Html_Renderer;
                             Enable : in Boolean);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Documents.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Get the current section number.
   function Get_Section_Number (Engine    : in Html_Renderer;
                                Prefix    : in Wiki.Strings.WString;
                                Separator : in Wiki.Strings.WChar) return Wiki.Strings.WString;

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Engine : in out Html_Renderer;
                             Level    : in Natural);

   --  Render a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Render_List_Item (Engine   : in out Html_Renderer;
                               Level    : in Positive;
                               Ordered  : in Boolean);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Html_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Wiki.Strings.WString);

   --  Render a table component such as N_TABLE, N_ROW or N_COLUMN.
   procedure Render_Table (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Documents.Document;
                           Node   : in Wiki.Nodes.Node_Type;
                           Tag    : in String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Documents.Document);

private

   procedure Close_Paragraph (Engine : in out Html_Renderer);
   procedure Open_Paragraph (Engine : in out Html_Renderer);

   type Toc_Number_Array is array (1 .. 6) of Natural;

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Wiki.Render.Links.Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output            : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format            : Wiki.Format_Map := (others => False);
      Links             : Wiki.Render.Links.Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph     : Boolean := False;
      Need_Paragraph    : Boolean := False;
      Has_Item          : Boolean := False;
      Enable_Render_TOC : Boolean := False;
      TOC_Rendered      : Boolean := False;
      No_Newline        : Boolean := False;
      Current_Level     : Natural := 0;
      Html_Tag          : Wiki.Html_Tag := BODY_TAG;
      List_Styles       : List_Style_Array := (others => False);
      Quote_Level       : Natural := 0;
      Html_Level        : Natural := 0;
      Current_Section   : Toc_Number_Array := (others => 0);
      Section_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Documents.Document;
                         Node   : in Wiki.Nodes.Node_Type);

   --  Render a section header in the document.
   procedure Render_Header (Engine : in out Html_Renderer;
                            Doc    : in Wiki.Documents.Document;
                            Header : in Wiki.Strings.WString;
                            Level  : in Positive);

   --  Render the table of content.
   procedure Render_TOC (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Documents.Document;
                         Level  : in Natural);

   --  Render a link.
   procedure Render_Link (Engine : in out Html_Renderer;
                          Doc    : in Wiki.Documents.Document;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List);

   --  Render an image.
   procedure Render_Image (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Documents.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Documents.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List);

   --  Returns true if the HTML element being included is already contained in a paragraph.
   --  This include: a, em, strong, small, b, i, u, s, span, ins, del, sub, sup.
   function Has_Html_Paragraph (Engine : in Html_Renderer) return Boolean;

end Wiki.Render.Html;

Declare the Render_Table procedure

Declare the Render_Table procedure


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

with Util.Serialize.IO.XML;
with Util.Serialize.Mappers;

with ASF.Applications.Main;
with ASF.Navigations.Mappers;
with ASF.Servlets.Mappers;
with ASF.Beans.Mappers;

--  The <b>AWA.Modules.Reader</b> package reads the module configuration files
--  and initializes the module.
package body AWA.Modules.Reader is

   --  ------------------------------
   --  Read the module configuration file and configure the components
   --  ------------------------------
   procedure Read_Configuration (Plugin  : in out Module'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.ELContext_Access) is

      procedure Add_Mapper (Mapper : in Util.Serialize.Mappers.Mapper_Access);

      Reader     : Util.Serialize.IO.XML.Parser;
      MBean      : aliased ASF.Beans.Mappers.Managed_Bean;
      Navigation : aliased ASF.Navigations.Mappers.Nav_Config;
      Servlet    : aliased ASF.Servlets.Mappers.Servlet_Config;

      procedure Add_Mapper (Mapper : in Util.Serialize.Mappers.Mapper_Access) is
      begin
         Reader.Add_Mapping ("faces-config", Mapper);
         Reader.Add_Mapping ("module", Mapper);
         Reader.Add_Mapping ("web-app", Mapper);
      end Add_Mapper;

   begin
      Log.Info ("Reading module configuration file {0}", File);

      Add_Mapper (ASF.Beans.Mappers.Get_Managed_Bean_Mapper);
      Add_Mapper (ASF.Navigations.Mappers.Get_Navigation_Mapper);
      Add_Mapper (ASF.Servlets.Mappers.Get_Servlet_Mapper);

      --  Setup the managed bean context to read the <managed-bean> elements.
      --  The ELContext is used for parsing EL expressions defined in property values.
      MBean.Factory := Plugin.Factory'Unchecked_Access;
      MBean.Context := Context;
      ASF.Beans.Mappers.Config_Mapper.Set_Context (Ctx     => Reader,
                                                   Element => MBean'Unchecked_Access);

      --  Setup the navigation context to read the <navigation-rule> elements.
      Navigation.Handler := Plugin.App.Get_Navigation_Handler;
      ASF.Navigations.Mappers.Case_Mapper.Set_Context (Ctx     => Reader,
                                                       Element => Navigation'Unchecked_Access);

      Servlet.Handler := Plugin.App.all'Unchecked_Access;
      ASF.Servlets.Mappers.Servlet_Mapper.Set_Context (Ctx     => Reader,
                                                       Element => Servlet'Unchecked_Access);

      Util.Serialize.IO.Dump (Reader, AWA.Modules.Log);

      --  Read the configuration file and record managed beans, navigation rules.
      Reader.Parse (File);
   end Read_Configuration;

end AWA.Modules.Reader;

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

with Util.Serialize.IO.XML;

with ASF.Applications.Main;
with ASF.Navigations.Mappers;
with ASF.Servlets.Mappers;
with ASF.Beans.Mappers;

--  The <b>AWA.Modules.Reader</b> package reads the module configuration files
--  and initializes the module.
package body AWA.Modules.Reader is

   --  ------------------------------
   --  Read the module configuration file and configure the components
   --  ------------------------------
   procedure Read_Configuration (Plugin  : in out Module'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.ELContext_Access) is

      Reader     : Util.Serialize.IO.XML.Parser;

      Nav : constant ASF.Navigations.Navigation_Handler_Access := Plugin.App.Get_Navigation_Handler;

      package Bean_Config is
        new ASF.Beans.Mappers.Reader_Config (Reader, Plugin.Factory'Unchecked_Access, Context);
      package Navigation_Config is
        new ASF.Navigations.Mappers.Reader_Config (Reader, Nav);
      package Servlet_Config is
        new ASF.Servlets.Mappers.Reader_Config (Reader, Plugin.App.all'Unchecked_Access);
      pragma Warnings (Off, Bean_Config);
      pragma Warnings (Off, Navigation_Config);
      pragma Warnings (Off, Servlet_Config);
   begin
      Log.Info ("Reading module configuration file {0}", File);

      Util.Serialize.IO.Dump (Reader, AWA.Modules.Log);

      --  Read the configuration file and record managed beans, navigation rules.
      Reader.Parse (File);
   end Read_Configuration;

end AWA.Modules.Reader;

Update Read_Configuration to use the new XXX_Config generic packages.


-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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 MAT.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

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

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  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 MAT.Frames;
with MAT.Readers;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural;
      Total_Alloc   : MAT.Types.Target_Size;
      Total_Free    : MAT.Types.Target_Size;
      Malloc_Count  : Natural;
      Free_Count    : Natural;
      Realloc_Count : Natural;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

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

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation);

   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation);

      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Stats         : Memory_Stat;
      Frames        : MAT.Frames.Frame_Type := MAT.Frames.Create_Root;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Reader        : MAT.Readers.Reader_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Define the Memory_Stat type to collect global statistics


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

package body Natools.Smaz is

   use type Ada.Streams.Stream_Element_Offset;

   function Dict_Entry
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return String
     with Pre => Index <= Dict.Dict_Last;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Index : out Ada.Streams.Stream_Element;
      Length : out Natural);

   function To_String (Data : in Ada.Streams.Stream_Element_Array)
     return String;

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Dict_Entry
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return String
   is
      First : constant Positive := Dict.Offsets (Index);
      Last : Natural := Dict.Values'Last;
   begin
      if Index + 1 in Dict.Offsets'Range then
         Last := Dict.Offsets (Index + 1) - 1;
      end if;

      return Dict.Values (First .. Last);
   end Dict_Entry;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Index : out Ada.Streams.Stream_Element;
      Length : out Natural)
   is
      I : Ada.Streams.Stream_Element;
      N : Natural;
   begin
      Index := Ada.Streams.Stream_Element'Last;
      Length := 0;

      for Last in reverse Template'Range loop
         N := Dict.Hash (Template (Template'First .. Last));

         if N <= Natural (Dict.Dict_Last) then
            I := Ada.Streams.Stream_Element (N);
            if Dict_Entry (Dict, I) = Template (Template'First .. Last) then
               Index := I;
               Length := 1 + Last - Template'First;
               return;
            end if;
         end if;
      end loop;
   end Find_Entry;

   function To_String (Data : in Ada.Streams.Stream_Element_Array)
     return String is
   begin
      return Result : String (1 .. Data'Length) do
         for I in Result'Range loop
            Result (I) := Character'Val (Data
              (Data'First + Ada.Streams.Stream_Element_Offset (I - 1)));
         end loop;
      end return;
   end To_String;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last - Dict.Dict_Last)
         - Boolean'Pos (Dict.Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;
   begin
      if Dict.Variable_Length_Verbatim then
         return Ada.Streams.Stream_Element_Count (Input'Length
           + 2 * (Input'Length + Verbatim2_Max_Size - 1) / Verbatim2_Max_Size);
      else
         return Ada.Streams.Stream_Element_Count (Input'Length
           + (Input'Length + Verbatim1_Max_Size - 1) / Verbatim1_Max_Size);
      end if;
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Entry;

      Verbatim1_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last - Dict.Dict_Last)
         - Boolean'Pos (Dict.Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Word : Ada.Streams.Stream_Element;

      procedure Find_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Word,
            Length);
      end Find_Entry;
   begin
      Output_Last := Output_Buffer'First - 1;
      Find_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Output_Last := Output_Last + 1;
            Output_Buffer (Output_Last) := Word;
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length, Block_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            Verbatim_Encode :
            while Verbatim_Length > 0 loop
               if Dict.Variable_Length_Verbatim
                 and then Verbatim_Length > Verbatim1_Max_Size
               then
                  Block_Length := Natural'Min
                    (Verbatim_Length, Verbatim2_Max_Size);
                  Output_Buffer (Output_Last + 1)
                    := Ada.Streams.Stream_Element'Last;
                  Output_Buffer (Output_Last + 2) := Ada.Streams.Stream_Element
                    (Block_Length - Verbatim1_Max_Size);
                  Output_Last := Output_Last + 2;
               else
                  Block_Length := Natural'Min
                    (Verbatim_Length, Verbatim1_Max_Size);
                  Output_Last := Output_Last + 1;
                  Output_Buffer (Output_Last)
                    := Ada.Streams.Stream_Element'Last
                     - Ada.Streams.Stream_Element
                        (Block_Length - 1
                          + Boolean'Pos (Dict.Variable_Length_Verbatim));
               end if;

               Verbatim_Copy :
               for I in Beginning .. Beginning + Block_Length - 1 loop
                  Output_Last := Output_Last + 1;
                  Output_Buffer (Output_Last) := Character'Pos (Input (I));
               end loop Verbatim_Copy;

               Verbatim_Length := Verbatim_Length - Block_Length;
               Beginning := Beginning + Block_Length;
            end loop Verbatim_Encode;
         end Verbatim_Block;
      end loop Main_Loop;
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Verbatim_Code_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset
           (Ada.Streams.Stream_Element'Last - Dict.Dict_Last);
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Input_Byte : Ada.Streams.Stream_Element;
      Verbatim_Length : Ada.Streams.Stream_Element_Offset;
   begin
      while Input_Index in Input'Range loop
         Input_Byte := Input (Input_Index);

         if Input_Byte in Dict.Offsets'Range then
            Result := Result + Dict_Entry (Dict, Input_Byte)'Length;
            Input_Index := Input_Index + 1;
         else
            if not Dict.Variable_Length_Verbatim then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
            elsif Input_Byte < Ada.Streams.Stream_Element'Last then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte);
            else
               Input_Index := Input_Index + 1;
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Input (Input_Index)) + Verbatim_Code_Count - 1;
            end if;

            Result := Result + Positive (Verbatim_Length);
            Input_Index := Input_Index + Verbatim_Length + 1;
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      procedure Append (S : in String);
      procedure Append (S : in Ada.Streams.Stream_Element_Array);

      procedure Append (S : in String) is
      begin
         Output_Buffer (Output_Last + 1 .. Output_Last + S'Length) := S;
         Output_Last := Output_Last + S'Length;
      end Append;

      procedure Append (S : in Ada.Streams.Stream_Element_Array) is
      begin
         Append (To_String (S));
      end Append;

      Verbatim_Code_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset
           (Ada.Streams.Stream_Element'Last - Dict.Dict_Last);

      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Input_Byte : Ada.Streams.Stream_Element;
      Verbatim_Length : Ada.Streams.Stream_Element_Offset;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Input_Byte := Input (Input_Index);

         if Input_Byte in Dict.Offsets'Range then
            Append (Dict_Entry (Dict, Input_Byte));
            Input_Index := Input_Index + 1;
         else
            if not Dict.Variable_Length_Verbatim then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
            elsif Input_Byte < Ada.Streams.Stream_Element'Last then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte);
            else
               Input_Index := Input_Index + 1;
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Input (Input_Index)) + Verbatim_Code_Count - 1;
            end if;

            Append (Input (Input_Index + 1 .. Input_Index + Verbatim_Length));
            Input_Index := Input_Index + Verbatim_Length + 1;
         end if;
      end loop;
   end Decompress;

end Natools.Smaz;

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

package body Natools.Smaz is

   use type Ada.Streams.Stream_Element_Offset;

   function Dict_Entry
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return String
     with Pre => Index <= Dict.Dict_Last;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Index : out Ada.Streams.Stream_Element;
      Length : out Natural);

   function To_String (Data : in Ada.Streams.Stream_Element_Array)
     return String;

   function Verbatim_Size (Dict : Dictionary; Original_Size : Natural)
     return Ada.Streams.Stream_Element_Count;

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   function Dict_Entry
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return String
   is
      First : constant Positive := Dict.Offsets (Index);
      Last : Natural := Dict.Values'Last;
   begin
      if Index + 1 in Dict.Offsets'Range then
         Last := Dict.Offsets (Index + 1) - 1;
      end if;

      return Dict.Values (First .. Last);
   end Dict_Entry;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Index : out Ada.Streams.Stream_Element;
      Length : out Natural)
   is
      I : Ada.Streams.Stream_Element;
      N : Natural;
   begin
      Index := Ada.Streams.Stream_Element'Last;
      Length := 0;

      for Last in reverse Template'Range loop
         N := Dict.Hash (Template (Template'First .. Last));

         if N <= Natural (Dict.Dict_Last) then
            I := Ada.Streams.Stream_Element (N);
            if Dict_Entry (Dict, I) = Template (Template'First .. Last) then
               Index := I;
               Length := 1 + Last - Template'First;
               return;
            end if;
         end if;
      end loop;
   end Find_Entry;

   function To_String (Data : in Ada.Streams.Stream_Element_Array)
     return String is
   begin
      return Result : String (1 .. Data'Length) do
         for I in Result'Range loop
            Result (I) := Character'Val (Data
              (Data'First + Ada.Streams.Stream_Element_Offset (I - 1)));
         end loop;
      end return;
   end To_String;

   function Verbatim_Size (Dict : Dictionary; Original_Size : Natural)
     return Ada.Streams.Stream_Element_Count
   is
      Verbatim1_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count
            (Ada.Streams.Stream_Element'Last - Dict.Dict_Last)
         - Boolean'Pos (Dict.Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Remaining : Ada.Streams.Stream_Element_Count
        := Ada.Streams.Stream_Element_Count (Original_Size);
      Overhead : Ada.Streams.Stream_Element_Count := 0;
   begin
      if Dict.Variable_Length_Verbatim then
         if Remaining >= Verbatim2_Max_Size then
            declare
               Full_Blocks : constant Ada.Streams.Stream_Element_Count
                 := Remaining / Verbatim2_Max_Size;
            begin
               Overhead := Overhead + 2 * Full_Blocks;
               Remaining := Remaining - Verbatim2_Max_Size * Full_Blocks;
            end;
         end if;

         if Remaining > Verbatim1_Max_Size then
            Overhead := Overhead + 2;
            Remaining := 0;
         end if;
      end if;

      declare
         Full_Blocks : constant Ada.Streams.Stream_Element_Count
           := Remaining / Verbatim1_Max_Size;
      begin
         Overhead := Overhead + Full_Blocks;
      end;

      return Overhead + Ada.Streams.Stream_Element_Count (Original_Size);
   end Verbatim_Size;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count is
   begin
      return Verbatim_Size (Dict, Input'Length);
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Entry;

      Verbatim1_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last - Dict.Dict_Last)
         - Boolean'Pos (Dict.Variable_Length_Verbatim);
      Verbatim2_Max_Size : constant Natural
        := Natural (Ada.Streams.Stream_Element'Last)
         + Verbatim1_Max_Size;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Word : Ada.Streams.Stream_Element;

      procedure Find_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Word,
            Length);
      end Find_Entry;

      Previous_Verbatim_Beginning : Natural := 0;
      Previous_Verbatim_Last : Ada.Streams.Stream_Element_Offset := 0;
   begin
      Output_Last := Output_Buffer'First - 1;
      Find_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Output_Last := Output_Last + 1;
            Output_Buffer (Output_Last) := Word;
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length, Block_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            if Previous_Verbatim_Beginning > 0
              and then Output_Last + Verbatim_Size (Dict, Verbatim_Length)
                 > Previous_Verbatim_Last + Verbatim_Size
                    (Dict, Input_Index - Previous_Verbatim_Beginning)
            then
               Beginning := Previous_Verbatim_Beginning;
               Output_Last := Previous_Verbatim_Last;
               Verbatim_Length := Input_Index - Beginning;
            else
               Previous_Verbatim_Beginning := Beginning;
               Previous_Verbatim_Last := Output_Last;
            end if;

            Verbatim_Encode :
            while Verbatim_Length > 0 loop
               if Dict.Variable_Length_Verbatim
                 and then Verbatim_Length > Verbatim1_Max_Size
               then
                  Block_Length := Natural'Min
                    (Verbatim_Length, Verbatim2_Max_Size);
                  Output_Buffer (Output_Last + 1)
                    := Ada.Streams.Stream_Element'Last;
                  Output_Buffer (Output_Last + 2) := Ada.Streams.Stream_Element
                    (Block_Length - Verbatim1_Max_Size);
                  Output_Last := Output_Last + 2;
               else
                  Block_Length := Natural'Min
                    (Verbatim_Length, Verbatim1_Max_Size);
                  Output_Last := Output_Last + 1;
                  Output_Buffer (Output_Last)
                    := Ada.Streams.Stream_Element'Last
                     - Ada.Streams.Stream_Element
                        (Block_Length - 1
                          + Boolean'Pos (Dict.Variable_Length_Verbatim));
               end if;

               Verbatim_Copy :
               for I in Beginning .. Beginning + Block_Length - 1 loop
                  Output_Last := Output_Last + 1;
                  Output_Buffer (Output_Last) := Character'Pos (Input (I));
               end loop Verbatim_Copy;

               Verbatim_Length := Verbatim_Length - Block_Length;
               Beginning := Beginning + Block_Length;
            end loop Verbatim_Encode;
         end Verbatim_Block;
      end loop Main_Loop;
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Verbatim_Code_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset
           (Ada.Streams.Stream_Element'Last - Dict.Dict_Last);
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Input_Byte : Ada.Streams.Stream_Element;
      Verbatim_Length : Ada.Streams.Stream_Element_Offset;
   begin
      while Input_Index in Input'Range loop
         Input_Byte := Input (Input_Index);

         if Input_Byte in Dict.Offsets'Range then
            Result := Result + Dict_Entry (Dict, Input_Byte)'Length;
            Input_Index := Input_Index + 1;
         else
            if not Dict.Variable_Length_Verbatim then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
            elsif Input_Byte < Ada.Streams.Stream_Element'Last then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte);
            else
               Input_Index := Input_Index + 1;
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Input (Input_Index)) + Verbatim_Code_Count - 1;
            end if;

            Result := Result + Positive (Verbatim_Length);
            Input_Index := Input_Index + Verbatim_Length + 1;
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      procedure Append (S : in String);
      procedure Append (S : in Ada.Streams.Stream_Element_Array);

      procedure Append (S : in String) is
      begin
         Output_Buffer (Output_Last + 1 .. Output_Last + S'Length) := S;
         Output_Last := Output_Last + S'Length;
      end Append;

      procedure Append (S : in Ada.Streams.Stream_Element_Array) is
      begin
         Append (To_String (S));
      end Append;

      Verbatim_Code_Count : constant Ada.Streams.Stream_Element_Offset
        := Ada.Streams.Stream_Element_Offset
           (Ada.Streams.Stream_Element'Last - Dict.Dict_Last);

      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Input_Byte : Ada.Streams.Stream_Element;
      Verbatim_Length : Ada.Streams.Stream_Element_Offset;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Input_Byte := Input (Input_Index);

         if Input_Byte in Dict.Offsets'Range then
            Append (Dict_Entry (Dict, Input_Byte));
            Input_Index := Input_Index + 1;
         else
            if not Dict.Variable_Length_Verbatim then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte) + 1;
            elsif Input_Byte < Ada.Streams.Stream_Element'Last then
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Ada.Streams.Stream_Element'Last - Input_Byte);
            else
               Input_Index := Input_Index + 1;
               Verbatim_Length := Ada.Streams.Stream_Element_Offset
                 (Input (Input_Index)) + Verbatim_Code_Count - 1;
            end if;

            Append (Input (Input_Index + 1 .. Input_Index + Verbatim_Length));
            Input_Index := Input_Index + Verbatim_Length + 1;
         end if;
      end loop;
   end Decompress;

end Natools.Smaz;

smaz: merge verbatim blocks when it improves compression