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

with Ada.Containers.Hashed_Maps;
with Util.Strings;

package Babel.Files.Maps is

   --  Babel.Base.Get_File_Map (Directory, File_Map);
   --  Babel.Base.Get_Directory_Map (Directory, Dir_Map);
   --  File_Map.Find (New_File);
   --  Dir_Map.Find (New_File);
   --  Hash string -> File
   package File_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Util.Strings.Name_Access,
                                 Element_Type    => File_Type,
                                 Hash            => Util.Strings.Hash,
                                 Equivalent_Keys => Util.Strings."=",
                                 "="             => "=");

   subtype File_Map is File_Maps.Map;
   subtype File_Cursor is File_Maps.Cursor;

   --  Find the file with the given name in the file map.
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor;

   --  Find the file with the given name in the file map.
   function Find (From : in File_Map;
                  Name : in String) return File_Type;

   --  Hash string -> Directory
   package Directory_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Util.Strings.Name_Access,
                                 Element_Type    => Directory_Type,
                                 Hash            => Util.Strings.Hash,
                                 Equivalent_Keys => Util.Strings."=",
                                 "="             => "=");

   subtype Directory_Map is Directory_Maps.Map;
   subtype Directory_Cursor is Directory_Maps.Cursor;

   type Differential_Container is new Babel.Files.Default_Container with private;

   --  Add the file with the given name in the container.
   overriding
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type);

   --  Add the directory with the given name in the container.
   overriding
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type);

   --  Create a new file instance with the given name in the container.
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type;

   --  Create a new directory instance with the given name in the container.
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type;

   --  Set the directory object associated with the container.
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type);

   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map));

private

   type Differential_Container is new Babel.Files.Default_Container with record
      Known_Files : File_Map;
      Known_Dirs  : Directory_Map;
   end record;

end Babel.Files.Maps;

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

with Ada.Containers.Hashed_Maps;
with Util.Strings;

package Babel.Files.Maps is

   --  Babel.Base.Get_File_Map (Directory, File_Map);
   --  Babel.Base.Get_Directory_Map (Directory, Dir_Map);
   --  File_Map.Find (New_File);
   --  Dir_Map.Find (New_File);
   --  Hash string -> File
   package File_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Util.Strings.Name_Access,
                                 Element_Type    => File_Type,
                                 Hash            => Util.Strings.Hash,
                                 Equivalent_Keys => Util.Strings."=",
                                 "="             => "=");

   subtype File_Map is File_Maps.Map;
   subtype File_Cursor is File_Maps.Cursor;

   --  Find the file with the given name in the file map.
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor;

   --  Find the file with the given name in the file map.
   function Find (From : in File_Map;
                  Name : in String) return File_Type;

   --  Hash string -> Directory
   package Directory_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Util.Strings.Name_Access,
                                 Element_Type    => Directory_Type,
                                 Hash            => Util.Strings.Hash,
                                 Equivalent_Keys => Util.Strings."=",
                                 "="             => "=");

   subtype Directory_Map is Directory_Maps.Map;
   subtype Directory_Cursor is Directory_Maps.Cursor;

   --  Find the directory with the given name in the directory map.
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Cursor;

   --  Find the directory with the given name in the directory map.
   function Find (From : in Directory_Map;
                  Name : in String) return Directory_Type;

   type Differential_Container is new Babel.Files.Default_Container with private;

   --  Add the file with the given name in the container.
   overriding
   procedure Add_File (Into    : in out Differential_Container;
                       Element : in File_Type);

   --  Add the directory with the given name in the container.
   overriding
   procedure Add_Directory (Into    : in out Differential_Container;
                            Element : in Directory_Type);

   --  Create a new file instance with the given name in the container.
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return File_Type;

   --  Create a new directory instance with the given name in the container.
   overriding
   function Create (Into : in Differential_Container;
                    Name : in String) return Directory_Type;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return File_Type;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   overriding
   function Find (From : in Differential_Container;
                  Name : in String) return Directory_Type;

   --  Set the directory object associated with the container.
   overriding
   procedure Set_Directory (Into      : in out Differential_Container;
                            Directory : in Directory_Type);

   --  Prepare the differential container by setting up the known files and known
   --  directories.  The <tt>Update</tt> procedure is called to give access to the
   --  maps that can be updated.
   procedure Prepare (Container : in out Differential_Container;
                      Update    : access procedure (Files : in out File_Map;
                                                    Dirs  : in out Directory_Map));

private

   type Differential_Container is new Babel.Files.Default_Container with record
      Known_Files : File_Map;
      Known_Dirs  : Directory_Map;
   end record;

end Babel.Files.Maps;

Define the Find operation to find a directory by its name


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

with ADO;
with ADO.Schemas.Mysql;
with ADO.Drivers;
with ADO.Sessions;
with ADO.Sessions.Factory;
with ADO.Schemas;

with Ada.Text_IO;

with Util.Log.Loggers;

procedure Pschema is

   use ADO;
   use Ada;
   use ADO.Schemas;

   Factory    : ADO.Sessions.Factory.Session_Factory;

begin
   Util.Log.Loggers.Initialize ("samples.properties");

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("samples.properties");

   --  Initialize the session factory to connect to the
   --  database defined by 'ado.database' property.
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB     : constant ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Driver : constant String := DB.Get_Connection.Get_Driver.Get_Driver_Name;
      Schema : ADO.Schemas.Schema_Definition;
      Iter   : Table_Cursor;
   begin
      if Driver /= "mysql" then
         Ada.Text_IO.Put_Line ("Loading and printing the database schema is supported for MySQL");
         return;
      end if;

      ADO.Schemas.Mysql.Load_Schema (DB.Get_Connection, Schema);

      --  Dump the database schema using SQL create table forms.
      Iter := Get_Tables (Schema);
      while Has_Element (Iter) loop
         declare
            Table      : constant Table_Definition := Element (Iter);
            Table_Iter : Column_Cursor := Get_Columns (Table);
         begin
            Ada.Text_IO.Put_Line ("create table " & Get_Name (Table) & " (");
            while Has_Element (Table_Iter) loop
               declare
                  Col : constant Column_Definition := Element (Table_Iter);
               begin
                  Ada.Text_IO.Put ("  ");
                  Ada.Text_IO.Put (Get_Name (Col));
                  Ada.Text_IO.Put (" ");
                  Ada.Text_IO.Put (Column_Type'Image (Get_Type (Col)));
                  if not Is_Null (Col) then
                     Ada.Text_IO.Put (" not null");
                  end if;
                  Ada.Text_IO.Put_Line (",");
               end;
               Next (Table_Iter);
            end loop;
            Ada.Text_IO.Put_Line (");");
         end;
         Next (Iter);
      end loop;
   end;
end Pschema;

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

with ADO;
with ADO.Drivers;
with ADO.Sessions;
with ADO.Sessions.Factory;
with ADO.Schemas;

with Ada.Text_IO;

with Util.Log.Loggers;

procedure Pschema is

   use ADO;
   use Ada;
   use ADO.Schemas;

   Factory    : ADO.Sessions.Factory.Session_Factory;

begin
   Util.Log.Loggers.Initialize ("samples.properties");

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("samples.properties");

   --  Initialize the session factory to connect to the
   --  database defined by 'ado.database' property.
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB     : constant ADO.Sessions.Master_Session := Factory.Get_Master_Session;
      Schema : ADO.Schemas.Schema_Definition;
      Iter   : Table_Cursor;
   begin
      DB.Load_Schema (Schema);

      --  Dump the database schema using SQL create table forms.
      Iter := Get_Tables (Schema);
      while Has_Element (Iter) loop
         declare
            Table      : constant Table_Definition := Element (Iter);
            Table_Iter : Column_Cursor := Get_Columns (Table);
         begin
            Ada.Text_IO.Put_Line ("create table " & Get_Name (Table) & " (");
            while Has_Element (Table_Iter) loop
               declare
                  Col : constant Column_Definition := Element (Table_Iter);
               begin
                  Ada.Text_IO.Put ("  ");
                  Ada.Text_IO.Put (Get_Name (Col));
                  Ada.Text_IO.Put (" ");
                  Ada.Text_IO.Put (Column_Type'Image (Get_Type (Col)));
                  if not Is_Null (Col) then
                     Ada.Text_IO.Put (" not null");
                  end if;
                  Ada.Text_IO.Put_Line (",");
               end;
               Next (Table_Iter);
            end loop;
            Ada.Text_IO.Put_Line (");");
         end;
         Next (Iter);
      end loop;
   end;
end Pschema;

Update the example to use the Load_Schema procedure and be independent of the database


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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Tags.Beans;
package body AWA.Tags.Modules.Tests is

   use Util.Tests;
   use ADO;

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

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Add_Tag",
                       Test_Add_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Remove_Tag",
                       Test_Remove_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Update_Tags",
                       Test_Remove_Tag'Access);
   end Add_Tests;

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access is
      Bean : constant Util.Beans.Basic.Readonly_Bean_Access
        := AWA.Tags.Beans.Create_Tag_List_Bean (Module);
   begin
      return AWA.Tags.Beans.Tag_List_Bean'Class (Bean.all)'Access;
   end Create_Tag_List_Bean;

   --  ------------------------------
   --  Test tag creation.
   --  ------------------------------
   procedure Test_Add_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-add-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         --  Create a tag.
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);

         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Add_Tag;

   --  ------------------------------
   --  Test tag removal.
   --  ------------------------------
   procedure Test_Remove_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-3");

         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Remove_Tag;

   --  ------------------------------
   --  Test tag creation and removal.
   --  ------------------------------
   procedure Test_Update_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
         Tags         : Util.Strings.Vectors.Vector;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));
         List.Set_Value ("permission",
                         Util.Beans.Objects.To_Object (String '("workspace-create")));

         --  Add 3 tags.
         Tags.Append ("user-tag-1");
         Tags.Append ("user-tag-2");
         Tags.Append ("user-tag-3");
         List.Set_Added (Tags);

         List.Update_Tags (User.Get_Id);

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 3, Integer (List.Get_Count), "Invalid number of tags");

         --  Remove a tag that was not created.
         Tags.Append ("user-tag-4");
         List.Set_Deleted (Tags);

         Tags.Clear;
         Tags.Append ("user-tag-5");
         List.Set_Added (Tags);
         List.Update_Tags (User.Get_Id);

         --  'user-tag-5' is the only tag that should exist now.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");

         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Update_Tag;

end AWA.Tags.Modules.Tests;

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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Tags.Beans;
package body AWA.Tags.Modules.Tests is

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

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Add_Tag",
                       Test_Add_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Remove_Tag",
                       Test_Remove_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Update_Tags",
                       Test_Remove_Tag'Access);
   end Add_Tests;

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access is
      Bean : constant Util.Beans.Basic.Readonly_Bean_Access
        := AWA.Tags.Beans.Create_Tag_List_Bean (Module);
   begin
      return AWA.Tags.Beans.Tag_List_Bean'Class (Bean.all)'Access;
   end Create_Tag_List_Bean;

   --  ------------------------------
   --  Test tag creation.
   --  ------------------------------
   procedure Test_Add_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-add-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         --  Create a tag.
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);

         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Add_Tag;

   --  ------------------------------
   --  Test tag removal.
   --  ------------------------------
   procedure Test_Remove_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-3");

         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Remove_Tag;

   --  ------------------------------
   --  Test tag creation and removal.
   --  ------------------------------
   procedure Test_Update_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
         Tags         : Util.Strings.Vectors.Vector;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));
         List.Set_Value ("permission",
                         Util.Beans.Objects.To_Object (String '("workspace-create")));

         --  Add 3 tags.
         Tags.Append ("user-tag-1");
         Tags.Append ("user-tag-2");
         Tags.Append ("user-tag-3");
         List.Set_Added (Tags);

         List.Update_Tags (User.Get_Id);

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 3, Integer (List.Get_Count), "Invalid number of tags");

         --  Remove a tag that was not created.
         Tags.Append ("user-tag-4");
         List.Set_Deleted (Tags);

         Tags.Clear;
         Tags.Append ("user-tag-5");
         List.Set_Added (Tags);
         List.Update_Tags (User.Get_Id);

         --  'user-tag-5' is the only tag that should exist now.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");

         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Update_Tag;

end AWA.Tags.Modules.Tests;

Fix compilation warning

Fix compilation warning


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

with Util.Log.Loggers;
with Babel.Files;
with Babel.Files.Buffers;
with Babel.Files.Lifecycles;
with Babel.Stores;
package body Babel.Strategies is

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

   --  ------------------------------
   --  Allocate a buffer to read the file content.
   --  ------------------------------
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access is
      Result : Babel.Files.Buffers.Buffer_Access;
   begin
      Strategy.Buffers.Get_Buffer (Result);
      return Result;
   end Allocate_Buffer;

   --  ------------------------------
   --  Release the buffer that was allocated by Allocate_Buffer.
   --  ------------------------------
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      Babel.Files.Buffers.Release (Buffer);
      Buffer := null;
   end Release_Buffer;

   --  ------------------------------
   --  Set the buffer pool to be used by Allocate_Buffer.
   --  ------------------------------
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Strategy.Buffers := Buffers;
   end Set_Buffers;

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Read_Store.Read (Path, Into.all);
   end Read_File;

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Write_Store.Write (Path, Content.all);
   end Write_File;

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in out Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      Strategy.Database.Insert (File);
      if Strategy.Listeners /= null then
         if Babel.Files.Is_New (File) then
            Babel.Files.Lifecycles.Notify_Create (Strategy.Listeners.all, File);
         else
            Babel.Files.Lifecycles.Notify_Update (Strategy.Listeners.all, File);
         end if;
      end if;
      Strategy.Write_File (File, Content);
      Strategy.Release_Buffer (Content);
   end Backup_File;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is
      Path : constant String := Babel.Files.Get_Path (Directory);
   begin
      Strategy.Read_Store.Scan (Path, Container, Strategy.Filters.all);
   end Scan;

   --  ------------------------------
   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   --  ------------------------------
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Append_Directory (Directory : in Babel.Files.Directory_Type) is
      begin
         Babel.Files.Queues.Add_Directory (Queue, Directory);
      end Append_Directory;

      Dir : Babel.Files.Directory_Type;
   begin
      while Babel.Files.Queues.Has_Directory (Queue) loop
         Babel.Files.Queues.Peek_Directory (Queue, Dir);
         Container.Set_Directory (Dir);
         Strategy_Type'Class (Strategy).Scan (Dir, Container);
         Container.Each_Directory (Append_Directory'Access);
      end loop;
   end Scan;

   --  ------------------------------
   --  Set the file filters that will be used when scanning the read store.
   --  ------------------------------
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access) is
   begin
      Strategy.Filters := Filters;
   end Set_Filters;

   --  ------------------------------
   --  Set the read and write stores that the strategy will use.
   --  ------------------------------
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access) is
   begin
      Strategy.Read_Store  := Read;
      Strategy.Write_Store := Write;
   end Set_Stores;

   --  ------------------------------
   --  Set the listeners to inform about changes.
   --  ------------------------------
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List) is
   begin
      Strategy.Listeners := Listeners;
   end Set_Listeners;

   --  ------------------------------
   --  Set the database for use by the strategy.
   --  ------------------------------
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access) is
   begin
      --        Strategy.Database := Database;
      null;
   end Set_Database;

end Babel.Strategies;

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

with Util.Log.Loggers;
with Babel.Files;
with Babel.Files.Buffers;
with Babel.Files.Lifecycles;
with Babel.Stores;
package body Babel.Strategies is

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

   --  ------------------------------
   --  Allocate a buffer to read the file content.
   --  ------------------------------
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access is
      Result : Babel.Files.Buffers.Buffer_Access;
   begin
      Strategy.Buffers.Get_Buffer (Result);
      return Result;
   end Allocate_Buffer;

   --  ------------------------------
   --  Release the buffer that was allocated by Allocate_Buffer.
   --  ------------------------------
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      Babel.Files.Buffers.Release (Buffer);
      Buffer := null;
   end Release_Buffer;

   --  ------------------------------
   --  Set the buffer pool to be used by Allocate_Buffer.
   --  ------------------------------
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Strategy.Buffers := Buffers;
   end Set_Buffers;

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Stream   : in out Babel.Streams.Refs.Stream_Ref) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Read_Store.Read_File (Path, Stream);
   end Read_File;

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Stream   : in Babel.Streams.Refs.Stream_Ref) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Write_Store.Write_File (Path, Stream, Babel.Files.Get_Mode (File));
   end Write_File;

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in out Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Stream   : in Babel.Streams.Refs.Stream_Ref) is
   begin
      Strategy.Database.Insert (File);
      if Strategy.Listeners /= null then
         if Babel.Files.Is_New (File) then
            Babel.Files.Lifecycles.Notify_Create (Strategy.Listeners.all, File);
         else
            Babel.Files.Lifecycles.Notify_Update (Strategy.Listeners.all, File);
         end if;
      end if;
      Strategy.Write_File (File, Stream);
   end Backup_File;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is
      Path : constant String := Babel.Files.Get_Path (Directory);
   begin
      Strategy.Read_Store.Scan (Path, Container, Strategy.Filters.all);
   end Scan;

   --  ------------------------------
   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   --  ------------------------------
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Append_Directory (Directory : in Babel.Files.Directory_Type) is
      begin
         Babel.Files.Queues.Add_Directory (Queue, Directory);
      end Append_Directory;

      Dir : Babel.Files.Directory_Type;
   begin
      while Babel.Files.Queues.Has_Directory (Queue) loop
         Babel.Files.Queues.Peek_Directory (Queue, Dir);
         Container.Set_Directory (Dir);
         Strategy_Type'Class (Strategy).Scan (Dir, Container);
         Container.Each_Directory (Append_Directory'Access);
      end loop;
   end Scan;

   --  ------------------------------
   --  Set the file filters that will be used when scanning the read store.
   --  ------------------------------
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access) is
   begin
      Strategy.Filters := Filters;
   end Set_Filters;

   --  ------------------------------
   --  Set the read and write stores that the strategy will use.
   --  ------------------------------
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access) is
   begin
      Strategy.Read_Store  := Read;
      Strategy.Write_Store := Write;
   end Set_Stores;

   --  ------------------------------
   --  Set the listeners to inform about changes.
   --  ------------------------------
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List) is
   begin
      Strategy.Listeners := Listeners;
   end Set_Listeners;

   --  ------------------------------
   --  Set the database for use by the strategy.
   --  ------------------------------
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access) is
   begin
      --        Strategy.Database := Database;
      null;
   end Set_Database;

end Babel.Strategies;

Use the Babel.Streams.Refs.Stream_Ref type for Read_File and Write_File operations


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

with Util.Log.Loggers;
with Babel.Files;
with Babel.Files.Buffers;
with Babel.Files.Lifecycles;
with Babel.Stores;
package body Babel.Strategies is

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

   --  ------------------------------
   --  Allocate a buffer to read the file content.
   --  ------------------------------
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access is
      Result : Babel.Files.Buffers.Buffer_Access;
   begin
      Strategy.Buffers.Get_Instance (Result);
      return Result;
   end Allocate_Buffer;

   --  ------------------------------
   --  Release the buffer that was allocated by Allocate_Buffer.
   --  ------------------------------
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      Strategy.Buffers.Release (Buffer);
      Buffer := null;
   end Release_Buffer;

   --  ------------------------------
   --  Set the buffer pool to be used by Allocate_Buffer.
   --  ------------------------------
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Strategy.Buffers := Buffers;
   end Set_Buffers;

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Read_Store.Read (Path, Into.all);
   end Read_File;

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Write_Store.Write (Path, Content.all);
   end Write_File;

   procedure Print_Sha (File : in Babel.Files.File_Type) is
      Sha : constant String := Babel.Files.Get_SHA1 (File);
   begin
      Log.Info (Babel.Files.Get_Path (File) & " => " & Sha);
   end Print_Sha;

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      if Babel.Files.Is_New (File) then
         Babel.Files.Lifecycles.Notify_Create (Strategy.Listeners.all, File);
      else
         Babel.Files.Lifecycles.Notify_Update (Strategy.Listeners.all, File);
      end if;
      Print_Sha (File);
      Strategy.Write_File (File, Content);
      Strategy.Release_Buffer (Content);
   end Backup_File;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is
      Path : constant String := Babel.Files.Get_Path (Directory);
   begin
      Strategy.Read_Store.Scan (Path, Container, Strategy.Filters.all);
   end Scan;

   --  ------------------------------
   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   --  ------------------------------
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Append_Directory (Directory : in Babel.Files.Directory_Type) is
      begin
         Babel.Files.Queues.Add_Directory (Queue, Directory);
      end Append_Directory;

      Dir : Babel.Files.Directory_Type;
   begin
      while Babel.Files.Queues.Has_Directory (Queue) loop
         Babel.Files.Queues.Peek_Directory (Queue, Dir);
         Container.Set_Directory (Dir);
         Strategy_Type'Class (Strategy).Scan (Dir, Container);
         Container.Each_Directory (Append_Directory'Access);
      end loop;
   end Scan;

   --  ------------------------------
   --  Set the file filters that will be used when scanning the read store.
   --  ------------------------------
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access) is
   begin
      Strategy.Filters := Filters;
   end Set_Filters;

   --  ------------------------------
   --  Set the read and write stores that the strategy will use.
   --  ------------------------------
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access) is
   begin
      Strategy.Read_Store  := Read;
      Strategy.Write_Store := Write;
   end Set_Stores;

   --  ------------------------------
   --  Set the listeners to inform about changes.
   --  ------------------------------
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List) is
   begin
      Strategy.Listeners := Listeners;
   end Set_Listeners;

end Babel.Strategies;

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

with Util.Log.Loggers;
with Babel.Files;
with Babel.Files.Buffers;
with Babel.Files.Lifecycles;
with Babel.Stores;
package body Babel.Strategies is

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

   --  ------------------------------
   --  Allocate a buffer to read the file content.
   --  ------------------------------
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access is
      Result : Babel.Files.Buffers.Buffer_Access;
   begin
      Strategy.Buffers.Get_Instance (Result);
      return Result;
   end Allocate_Buffer;

   --  ------------------------------
   --  Release the buffer that was allocated by Allocate_Buffer.
   --  ------------------------------
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      Strategy.Buffers.Release (Buffer);
      Buffer := null;
   end Release_Buffer;

   --  ------------------------------
   --  Set the buffer pool to be used by Allocate_Buffer.
   --  ------------------------------
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Strategy.Buffers := Buffers;
   end Set_Buffers;

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Read_Store.Read (Path, Into.all);
   end Read_File;

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access) is
      Path : constant String := Babel.Files.Get_Path (File);
   begin
      Strategy.Write_Store.Write (Path, Content.all);
   end Write_File;

   procedure Print_Sha (File : in Babel.Files.File_Type) is
      Sha : constant String := Babel.Files.Get_SHA1 (File);
   begin
      Log.Info (Babel.Files.Get_Path (File) & " => " & Sha);
   end Print_Sha;

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access) is
   begin
      if Babel.Files.Is_New (File) then
         Babel.Files.Lifecycles.Notify_Create (Strategy.Listeners.all, File);
      else
         Babel.Files.Lifecycles.Notify_Update (Strategy.Listeners.all, File);
      end if;
      Print_Sha (File);
      Strategy.Write_File (File, Content);
      Strategy.Release_Buffer (Content);
   end Backup_File;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is
      Path : constant String := Babel.Files.Get_Path (Directory);
   begin
      Strategy.Read_Store.Scan (Path, Container, Strategy.Filters.all);
   end Scan;

   --  ------------------------------
   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   --  ------------------------------
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Append_Directory (Directory : in Babel.Files.Directory_Type) is
      begin
         Babel.Files.Queues.Add_Directory (Queue, Directory);
      end Append_Directory;

      Dir : Babel.Files.Directory_Type;
   begin
      while Babel.Files.Queues.Has_Directory (Queue) loop
         Babel.Files.Queues.Peek_Directory (Queue, Dir);
         Container.Set_Directory (Dir);
         Strategy_Type'Class (Strategy).Scan (Dir, Container);
         Container.Each_Directory (Append_Directory'Access);
      end loop;
   end Scan;

   --  ------------------------------
   --  Set the file filters that will be used when scanning the read store.
   --  ------------------------------
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access) is
   begin
      Strategy.Filters := Filters;
   end Set_Filters;

   --  ------------------------------
   --  Set the read and write stores that the strategy will use.
   --  ------------------------------
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access) is
   begin
      Strategy.Read_Store  := Read;
      Strategy.Write_Store := Write;
   end Set_Stores;

   --  ------------------------------
   --  Set the listeners to inform about changes.
   --  ------------------------------
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List) is
   begin
      Strategy.Listeners := Listeners;
   end Set_Listeners;

   --  ------------------------------
   --  Set the database for use by the strategy.
   --  ------------------------------
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access) is
   begin
      Strategy.Database := Database;
   end Set_Database;

end Babel.Strategies;

Define the Set_Database operation

Define the Set_Database operation


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

with Util.Test_Caller;
package body Util.Locales.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Locale",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Language",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Country",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Variant",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Hash",
                       Test_Hash_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.=",
                       Test_Compare_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Locales",
                       Test_Get_Locales'Access);
   end Add_Tests;

   procedure Test_Get_Locale (T : in out Test) is
      Loc : Locale;
   begin
      Loc := Get_Locale ("en");
      Assert_Equals (T, "en", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("ja", "JP", "JP");
      Assert_Equals (T, "ja", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "JP", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "JP", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("no", "NO", "NY");
      Assert_Equals (T, "no", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "NO", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "NY", Get_Variant (Loc), "Invalid variant");
   end Test_Get_Locale;

   procedure Test_Hash_Locale (T : in out Test) is
      use type Ada.Containers.Hash_Type;
   begin
      T.Assert (Hash (FRANCE) /= Hash (FRENCH), "Hash should be different");
      T.Assert (Hash (FRANCE) /= Hash (ENGLISH), "Hash should be different");
      T.Assert (Hash (FRENCH) /= Hash (ENGLISH), "Hash should be different");
   end Test_Hash_Locale;

   procedure Test_Compare_Locale (T : in out Test) is
   begin
      T.Assert (FRANCE /= FRENCH, "Equality");
      T.Assert (FRANCE = FRANCE, "Equality");
      T.Assert (FRANCE = Get_Locale ("fr", "FR"), "Equality");
      T.Assert (FRANCE /= ENGLISH, "Equality");
      T.Assert (FRENCH /= ENGLISH, "Equaliy");
   end Test_Compare_Locale;

   procedure Test_Get_Locales (T : in out Test) is
   begin
      for I in Locales'Range loop
         declare
            Language : constant String := Get_Language (Locales (I));
            Country  : constant String := Get_Country (Locales (I));
            Variant  : constant String := Get_Variant (Locales (I));
            Loc      : constant Locale := Get_Locale (Language, Country, Variant);
            Name     : constant String := To_String (Loc);
         begin
            T.Assert (Loc = Locales (I), "Invalid locale at " & Positive'Image (I)
                      & " " & Loc.all);
            if Variant'Length > 0 then
               Assert (T, Name, Language & "_" & Country & "_" & Variant, "Invalid To_String");
            elsif Country'Length > 0 then
               Assert (T, Name, Language & "_" & Country, "Invalid To_String");
            else
               Assert (T, Name, Language, "Invalid To_String");
            end if;
         end;
      end loop;
   end Test_Get_Locales;

end Util.Locales.Tests;

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

with Util.Test_Caller;
package body Util.Locales.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Locale",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Language",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Country",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Get_Variant",
                       Test_Get_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Hash",
                       Test_Hash_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.=",
                       Test_Compare_Locale'Access);
      Caller.Add_Test (Suite, "Test Util.Locales.Locales",
                       Test_Get_Locales'Access);
   end Add_Tests;

   procedure Test_Get_Locale (T : in out Test) is
      Loc : Locale;
   begin
      Loc := Get_Locale ("en");
      Assert_Equals (T, "en", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("ja", "JP", "JP");
      Assert_Equals (T, "ja", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "JP", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "JP", Get_Variant (Loc), "Invalid variant");

      Loc := Get_Locale ("no", "NO", "NY");
      Assert_Equals (T, "no", Get_Language (Loc), "Invalid language");
      Assert_Equals (T, "NO", Get_Country (Loc), "Invalid country");
      Assert_Equals (T, "NY", Get_Variant (Loc), "Invalid variant");
   end Test_Get_Locale;

   procedure Test_Hash_Locale (T : in out Test) is
      use type Ada.Containers.Hash_Type;
   begin
      T.Assert (Hash (FRANCE) /= Hash (FRENCH), "Hash should be different");
      T.Assert (Hash (FRANCE) /= Hash (ENGLISH), "Hash should be different");
      T.Assert (Hash (FRENCH) /= Hash (ENGLISH), "Hash should be different");
   end Test_Hash_Locale;

   procedure Test_Compare_Locale (T : in out Test) is
   begin
      T.Assert (FRANCE /= FRENCH, "Equality");
      T.Assert (FRANCE = FRANCE, "Equality");
      T.Assert (FRANCE = Get_Locale ("fr", "FR"), "Equality");
      T.Assert (FRANCE /= ENGLISH, "Equality");
      T.Assert (FRENCH /= ENGLISH, "Equaliy");
   end Test_Compare_Locale;

   procedure Test_Get_Locales (T : in out Test) is
   begin
      for I in Locales'Range loop
         declare
            Language : constant String := Get_Language (Locales (I));
            Country  : constant String := Get_Country (Locales (I));
            Variant  : constant String := Get_Variant (Locales (I));
            Loc      : constant Locale := Get_Locale (Language, Country, Variant);
            Name     : constant String := To_String (Loc);
         begin
            T.Assert (Loc = Locales (I), "Invalid locale at " & Positive'Image (I)
                      & " " & Loc.all);
            if Variant'Length > 0 then
               Assert_Equals (T, Name, Language & "_" & Country & "_" & Variant,
                              "Invalid To_String");
            elsif Country'Length > 0 then
               Assert_Equals (T, Name, Language & "_" & Country, "Invalid To_String");
            else
               Assert_Equals (T, Name, Language, "Invalid To_String");
            end if;
         end;
      end loop;
   end Test_Get_Locales;

end Util.Locales.Tests;

Fix compilation with GNAT 2011

Fix compilation with GNAT 2011


------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Generic_Caches provides a simple memory container  --
-- for S-expressions. The container is append-only, and provides cursors to --
-- replay it from start.                                                    --
-- This is a generic package that allow client-selected storage pools. An   --
-- instance with default storage pools is provided in                       --
-- Natools.S_Expressions.Caches.                                            --
-- The intended usage is efficient caching of S-expressions in memory. For  --
-- more flexible in-memory S-expression objects,                            --
-- see Natools.S_Expressions.Holders.                                       --
------------------------------------------------------------------------------

with System.Storage_Pools;

with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Replayable;

private with Ada.Finalization;
private with Ada.Unchecked_Deallocation;
private with Natools.References;

generic
   Atom_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;
   Counter_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;
   Structure_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;

package Natools.S_Expressions.Generic_Caches is
   pragma Preelaborate (Generic_Caches);

   type Reference is new Printers.Printer with private;
   pragma Preelaborable_Initialization (Reference);

   overriding procedure Open_List (Output : in out Reference);
   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom);
   overriding procedure Close_List (Output : in out Reference);

   function Duplicate (Cache : Reference) return Reference;
      --  Create a new copy of the S-expression held in Cache and return it

   function Move (Source : in out S_Expressions.Descriptor'Class)
     return Reference;
      --  Build a new cache by (destructively) reading Original

   type Cursor is new Lockable.Descriptor and Replayable.Descriptor
     with private;
   pragma Preelaborable_Initialization (Cursor);

   overriding function Current_Event (Object : in Cursor) return Events.Event;
   overriding function Current_Atom (Object : in Cursor) return Atom;
   overriding function Current_Level (Object : in Cursor) return Natural;
   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom));
   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count);
   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event);

   overriding procedure Lock
     (Object : in out Cursor;
      State : out Lockable.Lock_State);
   overriding procedure Unlock
     (Object : in out Cursor;
      State : in out Lockable.Lock_State;
      Finish : in Boolean := True);

   overriding function Duplicate (Object : Cursor) return Cursor;

   function First (Cache : Reference'Class) return Cursor;
      --  Create a new Cursor pointing at the beginning of Cache

   function Move (Source : in out S_Expressions.Descriptor'Class) return Cursor
     is (Move (Source).First);
      --  Return a cursor holding a copy of Original (which is
      --  destructively read)

private

   type Atom_Access is access Atom;
   for Atom_Access'Storage_Pool use Atom_Pool;
   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Atom, Atom_Access);

   type Node;
   type Node_Access is access Node;
   for Node_Access'Storage_Pool use Structure_Pool;

   type Node_Kind is (Atom_Node, List_Node);

   type Node (Kind : Node_Kind) is record
      Parent : Node_Access;
      Next : Node_Access;

      case Kind is
         when Atom_Node => Data : Atom_Access;
         when List_Node => Child : Node_Access;
      end case;
   end record;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Node, Node_Access);

   type Tree is new Ada.Finalization.Limited_Controlled with record
      Root : Node_Access := null;
      Last : Node_Access := null;
      Opening : Boolean := False;
   end record;

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null);
      --  Append a new node of the given Kind to Exp

   procedure Close_List (Exp : in out Tree);
      --  Close innermost list

   function Create_Tree return Tree;
      --  Create a new empty Tree

   function Duplicate (Source : Tree) return Tree;
      --  Deep copy of a Tree object

   overriding procedure Finalize (Object : in out Tree);
      --  Release all nodes contained in Object

   package Trees is new References (Tree, Structure_Pool, Counter_Pool);

   type Reference is new Printers.Printer with record
      Exp : Trees.Reference;
   end record;

   type Cursor is new Lockable.Descriptor and Replayable.Descriptor with record
      Exp : Trees.Reference;
      Position : Node_Access := null;
      Opening : Boolean := False;
      Stack : Lockable.Lock_Stack;
      Locked : Boolean := False;
   end record;

   function Absolute_Level (Object : Cursor) return Natural;

end Natools.S_Expressions.Generic_Caches;

------------------------------------------------------------------------------
-- Copyright (c) 2013-2019, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Generic_Caches provides a simple memory container  --
-- for S-expressions. The container is append-only, and provides cursors to --
-- replay it from start.                                                    --
-- This is a generic package that allow client-selected storage pools. An   --
-- instance with default storage pools is provided in                       --
-- Natools.S_Expressions.Caches.                                            --
-- The intended usage is efficient caching of S-expressions in memory. For  --
-- more flexible in-memory S-expression objects,                            --
-- see Natools.S_Expressions.Holders.                                       --
------------------------------------------------------------------------------

with System.Storage_Pools;

with Natools.S_Expressions.Lockable;
with Natools.S_Expressions.Printers;
with Natools.S_Expressions.Replayable;

private with Ada.Finalization;
private with Ada.Unchecked_Deallocation;
private with Natools.References;

generic
   Atom_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;
   Counter_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;
   Structure_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class;

package Natools.S_Expressions.Generic_Caches is
   pragma Preelaborate (Generic_Caches);

   type Reference is new Printers.Printer with private;
   pragma Preelaborable_Initialization (Reference);

   overriding procedure Open_List (Output : in out Reference);
   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom);
   overriding procedure Close_List (Output : in out Reference);

   function Duplicate (Cache : Reference) return Reference;
      --  Create a new copy of the S-expression held in Cache and return it

   function Move (Source : in out S_Expressions.Descriptor'Class)
     return Reference;
      --  Build a new cache by (destructively) reading Original

   type Cursor is new Lockable.Descriptor and Replayable.Descriptor
     with private;
   pragma Preelaborable_Initialization (Cursor);

   overriding function Current_Event (Object : in Cursor) return Events.Event;
   overriding function Current_Atom (Object : in Cursor) return Atom;
   overriding function Current_Level (Object : in Cursor) return Natural;
   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom));
   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count);
   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event);

   overriding procedure Lock
     (Object : in out Cursor;
      State : out Lockable.Lock_State);
   overriding procedure Unlock
     (Object : in out Cursor;
      State : in out Lockable.Lock_State;
      Finish : in Boolean := True);

   overriding function Duplicate (Object : Cursor) return Cursor;

   function First (Cache : Reference'Class) return Cursor;
      --  Create a new Cursor pointing at the beginning of Cache

   function Move (Source : in out S_Expressions.Descriptor'Class) return Cursor
     is (Move (Source).First);
      --  Return a cursor holding a copy of Original (which is
      --  destructively read)

   function Conditional_Move
     (Source : in out S_Expressions.Descriptor'Class)
     return Cursor
     is (if Source in Cursor then Cursor (Source) else Move (Source).First);
      --  Return a copy of Source, with cheap copy if possible,
      --  otherwise with destructive Move

private

   type Atom_Access is access Atom;
   for Atom_Access'Storage_Pool use Atom_Pool;
   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Atom, Atom_Access);

   type Node;
   type Node_Access is access Node;
   for Node_Access'Storage_Pool use Structure_Pool;

   type Node_Kind is (Atom_Node, List_Node);

   type Node (Kind : Node_Kind) is record
      Parent : Node_Access;
      Next : Node_Access;

      case Kind is
         when Atom_Node => Data : Atom_Access;
         when List_Node => Child : Node_Access;
      end case;
   end record;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
     (Node, Node_Access);

   type Tree is new Ada.Finalization.Limited_Controlled with record
      Root : Node_Access := null;
      Last : Node_Access := null;
      Opening : Boolean := False;
   end record;

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null);
      --  Append a new node of the given Kind to Exp

   procedure Close_List (Exp : in out Tree);
      --  Close innermost list

   function Create_Tree return Tree;
      --  Create a new empty Tree

   function Duplicate (Source : Tree) return Tree;
      --  Deep copy of a Tree object

   overriding procedure Finalize (Object : in out Tree);
      --  Release all nodes contained in Object

   package Trees is new References (Tree, Structure_Pool, Counter_Pool);

   type Reference is new Printers.Printer with record
      Exp : Trees.Reference;
   end record;

   type Cursor is new Lockable.Descriptor and Replayable.Descriptor with record
      Exp : Trees.Reference;
      Position : Node_Access := null;
      Opening : Boolean := False;
      Stack : Lockable.Lock_Stack;
      Locked : Boolean := False;
   end record;

   function Absolute_Level (Object : Cursor) return Natural;

end Natools.S_Expressions.Generic_Caches;

s_expressions-generic_caches: add a cheaper-when-possible alternative to Move