-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  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.Files.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
   end Add_Tests;

   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  Check writing a file
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  Check Find_File_Path
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
            Last := To_Unbounded_String (Dir);
         end if;
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                     Compose_Path ("/usr;/usr/local;/usr", "bin"),
                     "Invalid path composition");
   end Test_Compose_Path;

end Util.Files.Tests;

-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  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 Ada.Directories;
with Util.Test_Caller;
package body Util.Files.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
   end Add_Tests;

   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  Check writing a file
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  Check Find_File_Path
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
            Last := To_Unbounded_String (Dir);
         end if;
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

end Util.Files.Tests;

Fix execution of Compose unit test on Windows - Do not execute one test that relies on the availability of /usr/bin directory - Add a compose test that uses the util directory hierarchy.


-----------------------------------------------------------------------
--  AWA.Tags.Models -- AWA.Tags.Models
-----------------------------------------------------------------------
--  File generated by ada-gen DO NOT MODIFY
--  Template used: templates/model/package-spec.xhtml
--  Ada Generator: https://ada-gen.googlecode.com/svn/trunk Revision 1095
-----------------------------------------------------------------------
--  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.
-----------------------------------------------------------------------
pragma Warnings (Off, "unit * is not referenced");
with ADO.Sessions;
with ADO.Objects;
with ADO.Statements;
with ADO.SQL;
with ADO.Schemas;
with ADO.Queries;
with ADO.Queries.Loaders;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Util.Beans.Objects;
with Util.Beans.Basic.Lists;
pragma Warnings (On, "unit * is not referenced");
package AWA.Tags.Models is
   type Tag_Ref is new ADO.Objects.Object_Ref with null record;

   type Tagged_Entity_Ref is new ADO.Objects.Object_Ref with null record;

   --  --------------------
   --  The tag definition.
   --  --------------------
   --  Create an object key for Tag.
   function Tag_Key (Id : in ADO.Identifier) return ADO.Objects.Object_Key;
   --  Create an object key for Tag from a string.
   --  Raises Constraint_Error if the string cannot be converted into the object key.
   function Tag_Key (Id : in String) return ADO.Objects.Object_Key;

   Null_Tag : constant Tag_Ref;
   function "=" (Left, Right : Tag_Ref'Class) return Boolean;

   --  Set the tag identifier
   procedure Set_Id (Object : in out Tag_Ref;
                     Value  : in ADO.Identifier);

   --  Get the tag identifier
   function Get_Id (Object : in Tag_Ref)
                 return ADO.Identifier;

   --  Set the tag name
   procedure Set_Name (Object : in out Tag_Ref;
                       Value  : in Ada.Strings.Unbounded.Unbounded_String);
   procedure Set_Name (Object : in out Tag_Ref;
                       Value : in String);

   --  Get the tag name
   function Get_Name (Object : in Tag_Ref)
                 return Ada.Strings.Unbounded.Unbounded_String;
   function Get_Name (Object : in Tag_Ref)
                 return String;

   --  Load the entity identified by 'Id'.
   --  Raises the NOT_FOUND exception if it does not exist.
   procedure Load (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier);

   --  Load the entity identified by 'Id'.
   --  Returns True in Found if the object was found and False if it does not exist.
   procedure Load (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier;
                   Found   : out Boolean);

   --  Find and load the entity.
   overriding
   procedure Find (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   --  Save the entity.  If the entity does not have an identifier, an identifier is allocated
   --  and it is inserted in the table.  Otherwise, only data fields which have been changed
   --  are updated.
   overriding
   procedure Save (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Master_Session'Class);

   --  Delete the entity.
   overriding
   procedure Delete (Object  : in out Tag_Ref;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   function Get_Value (From : in Tag_Ref;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Table definition
   TAG_TABLE : constant ADO.Schemas.Class_Mapping_Access;

   --  Internal method to allocate the Object_Record instance
   overriding
   procedure Allocate (Object : in out Tag_Ref);

   --  Copy of the object.
   procedure Copy (Object : in Tag_Ref;
                   Into   : in out Tag_Ref);

   package Tag_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Natural,
                                  Element_Type => Tag_Ref,
                                  "="          => "=");
   subtype Tag_Vector is Tag_Vectors.Vector;

   procedure List (Object  : in out Tag_Vector;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class);
   --  Create an object key for Tagged_Entity.
   function Tagged_Entity_Key (Id : in ADO.Identifier) return ADO.Objects.Object_Key;
   --  Create an object key for Tagged_Entity from a string.
   --  Raises Constraint_Error if the string cannot be converted into the object key.
   function Tagged_Entity_Key (Id : in String) return ADO.Objects.Object_Key;

   Null_Tagged_Entity : constant Tagged_Entity_Ref;
   function "=" (Left, Right : Tagged_Entity_Ref'Class) return Boolean;

   --  Set the tag entity identifier
   procedure Set_Id (Object : in out Tagged_Entity_Ref;
                     Value  : in ADO.Identifier);

   --  Get the tag entity identifier
   function Get_Id (Object : in Tagged_Entity_Ref)
                 return ADO.Identifier;

   --  Set Title: Tag model
   --  Date: 2013-02-23the database entity to which the tag is associated
   procedure Set_For_Entity_Id (Object : in out Tagged_Entity_Ref;
                                Value  : in ADO.Identifier);

   --  Get Title: Tag model
   --  Date: 2013-02-23the database entity to which the tag is associated
   function Get_For_Entity_Id (Object : in Tagged_Entity_Ref)
                 return ADO.Identifier;

   --  Set the entity type
   procedure Set_Entity_Type (Object : in out Tagged_Entity_Ref;
                              Value  : in ADO.Entity_Type);

   --  Get the entity type
   function Get_Entity_Type (Object : in Tagged_Entity_Ref)
                 return ADO.Entity_Type;

   --
   procedure Set_Tag (Object : in out Tagged_Entity_Ref;
                      Value  : in AWA.Tags.Models.Tag_Ref'Class);

   --
   function Get_Tag (Object : in Tagged_Entity_Ref)
                 return AWA.Tags.Models.Tag_Ref'Class;

   --  Load the entity identified by 'Id'.
   --  Raises the NOT_FOUND exception if it does not exist.
   procedure Load (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier);

   --  Load the entity identified by 'Id'.
   --  Returns True in Found if the object was found and False if it does not exist.
   procedure Load (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier;
                   Found   : out Boolean);

   --  Find and load the entity.
   overriding
   procedure Find (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   --  Save the entity.  If the entity does not have an identifier, an identifier is allocated
   --  and it is inserted in the table.  Otherwise, only data fields which have been changed
   --  are updated.
   overriding
   procedure Save (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Master_Session'Class);

   --  Delete the entity.
   overriding
   procedure Delete (Object  : in out Tagged_Entity_Ref;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   function Get_Value (From : in Tagged_Entity_Ref;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Table definition
   TAGGED_ENTITY_TABLE : constant ADO.Schemas.Class_Mapping_Access;

   --  Internal method to allocate the Object_Record instance
   overriding
   procedure Allocate (Object : in out Tagged_Entity_Ref);

   --  Copy of the object.
   procedure Copy (Object : in Tagged_Entity_Ref;
                   Into   : in out Tagged_Entity_Ref);

   package Tagged_Entity_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Natural,
                                  Element_Type => Tagged_Entity_Ref,
                                  "="          => "=");
   subtype Tagged_Entity_Vector is Tagged_Entity_Vectors.Vector;

   procedure List (Object  : in out Tagged_Entity_Vector;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class);

   Query_Check_Tag : constant ADO.Queries.Query_Definition_Access;

private
   TAG_NAME : aliased constant String := "awa_tag";
   COL_0_1_NAME : aliased constant String := "id";
   COL_1_1_NAME : aliased constant String := "name";

   TAG_DEF : aliased constant ADO.Schemas.Class_Mapping :=
     (Count => 2,
      Table => TAG_NAME'Access,
      Members => (
         1 => COL_0_1_NAME'Access,
         2 => COL_1_1_NAME'Access
)
     );
   TAG_TABLE : constant ADO.Schemas.Class_Mapping_Access
      := TAG_DEF'Access;

   Null_Tag : constant Tag_Ref
      := Tag_Ref'(ADO.Objects.Object_Ref with others => <>);

   type Tag_Impl is
      new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                     Of_Class => TAG_DEF'Access)
   with record
       Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Tag_Access is access all Tag_Impl;

   overriding
   procedure Destroy (Object : access Tag_Impl);

   overriding
   procedure Find (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Session'Class);
   procedure Load (Object  : in out Tag_Impl;
                   Stmt    : in out ADO.Statements.Query_Statement'Class;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   procedure Create (Object  : in out Tag_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Tag_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   procedure Set_Field (Object : in out Tag_Ref'Class;
                        Impl   : out Tag_Access);
   TAGGED_ENTITY_NAME : aliased constant String := "awa_tagged_entity";
   COL_0_2_NAME : aliased constant String := "id";
   COL_1_2_NAME : aliased constant String := "for_entity_id";
   COL_2_2_NAME : aliased constant String := "entity_type";
   COL_3_2_NAME : aliased constant String := "tag_id";

   TAGGED_ENTITY_DEF : aliased constant ADO.Schemas.Class_Mapping :=
     (Count => 4,
      Table => TAGGED_ENTITY_NAME'Access,
      Members => (
         1 => COL_0_2_NAME'Access,
         2 => COL_1_2_NAME'Access,
         3 => COL_2_2_NAME'Access,
         4 => COL_3_2_NAME'Access
)
     );
   TAGGED_ENTITY_TABLE : constant ADO.Schemas.Class_Mapping_Access
      := TAGGED_ENTITY_DEF'Access;

   Null_Tagged_Entity : constant Tagged_Entity_Ref
      := Tagged_Entity_Ref'(ADO.Objects.Object_Ref with others => <>);

   type Tagged_Entity_Impl is
      new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                     Of_Class => TAGGED_ENTITY_DEF'Access)
   with record
       For_Entity_Id : ADO.Identifier;
       Entity_Type : ADO.Entity_Type;
       Tag : AWA.Tags.Models.Tag_Ref;
   end record;

   type Tagged_Entity_Access is access all Tagged_Entity_Impl;

   overriding
   procedure Destroy (Object : access Tagged_Entity_Impl);

   overriding
   procedure Find (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Session'Class);
   procedure Load (Object  : in out Tagged_Entity_Impl;
                   Stmt    : in out ADO.Statements.Query_Statement'Class;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   procedure Create (Object  : in out Tagged_Entity_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Tagged_Entity_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   procedure Set_Field (Object : in out Tagged_Entity_Ref'Class;
                        Impl   : out Tagged_Entity_Access);

   package File_1 is
      new ADO.Queries.Loaders.File (Path => "tag-queries.xml",
                                    Sha1 => "9B2B599473F75F92CB5AB5045675E4CCEF926543");

   package Def_Check_Tag is
      new ADO.Queries.Loaders.Query (Name => "check-tag",
                                     File => File_1.File'Access);
   Query_Check_Tag : constant ADO.Queries.Query_Definition_Access
   := Def_Check_Tag.Query'Access;
end AWA.Tags.Models;

-----------------------------------------------------------------------
--  AWA.Tags.Models -- AWA.Tags.Models
-----------------------------------------------------------------------
--  File generated by ada-gen DO NOT MODIFY
--  Template used: templates/model/package-spec.xhtml
--  Ada Generator: https://ada-gen.googlecode.com/svn/trunk Revision 1095
-----------------------------------------------------------------------
--  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.
-----------------------------------------------------------------------
pragma Warnings (Off, "unit * is not referenced");
with ADO.Sessions;
with ADO.Objects;
with ADO.Statements;
with ADO.SQL;
with ADO.Schemas;
with ADO.Queries;
with ADO.Queries.Loaders;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded;
with Util.Beans.Objects;
with Util.Beans.Basic.Lists;
pragma Warnings (On, "unit * is not referenced");
package AWA.Tags.Models is
   type Tag_Ref is new ADO.Objects.Object_Ref with null record;

   type Tagged_Entity_Ref is new ADO.Objects.Object_Ref with null record;

   --  --------------------
   --  The tag definition.
   --  --------------------
   --  Create an object key for Tag.
   function Tag_Key (Id : in ADO.Identifier) return ADO.Objects.Object_Key;
   --  Create an object key for Tag from a string.
   --  Raises Constraint_Error if the string cannot be converted into the object key.
   function Tag_Key (Id : in String) return ADO.Objects.Object_Key;

   Null_Tag : constant Tag_Ref;
   function "=" (Left, Right : Tag_Ref'Class) return Boolean;

   --  Set the tag identifier
   procedure Set_Id (Object : in out Tag_Ref;
                     Value  : in ADO.Identifier);

   --  Get the tag identifier
   function Get_Id (Object : in Tag_Ref)
                 return ADO.Identifier;

   --  Set the tag name
   procedure Set_Name (Object : in out Tag_Ref;
                       Value  : in Ada.Strings.Unbounded.Unbounded_String);
   procedure Set_Name (Object : in out Tag_Ref;
                       Value : in String);

   --  Get the tag name
   function Get_Name (Object : in Tag_Ref)
                 return Ada.Strings.Unbounded.Unbounded_String;
   function Get_Name (Object : in Tag_Ref)
                 return String;

   --  Load the entity identified by 'Id'.
   --  Raises the NOT_FOUND exception if it does not exist.
   procedure Load (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier);

   --  Load the entity identified by 'Id'.
   --  Returns True in Found if the object was found and False if it does not exist.
   procedure Load (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier;
                   Found   : out Boolean);

   --  Find and load the entity.
   overriding
   procedure Find (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   --  Save the entity.  If the entity does not have an identifier, an identifier is allocated
   --  and it is inserted in the table.  Otherwise, only data fields which have been changed
   --  are updated.
   overriding
   procedure Save (Object  : in out Tag_Ref;
                   Session : in out ADO.Sessions.Master_Session'Class);

   --  Delete the entity.
   overriding
   procedure Delete (Object  : in out Tag_Ref;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   function Get_Value (From : in Tag_Ref;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Table definition
   TAG_TABLE : constant ADO.Schemas.Class_Mapping_Access;

   --  Internal method to allocate the Object_Record instance
   overriding
   procedure Allocate (Object : in out Tag_Ref);

   --  Copy of the object.
   procedure Copy (Object : in Tag_Ref;
                   Into   : in out Tag_Ref);

   package Tag_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Natural,
                                  Element_Type => Tag_Ref,
                                  "="          => "=");
   subtype Tag_Vector is Tag_Vectors.Vector;

   procedure List (Object  : in out Tag_Vector;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class);
   --  Create an object key for Tagged_Entity.
   function Tagged_Entity_Key (Id : in ADO.Identifier) return ADO.Objects.Object_Key;
   --  Create an object key for Tagged_Entity from a string.
   --  Raises Constraint_Error if the string cannot be converted into the object key.
   function Tagged_Entity_Key (Id : in String) return ADO.Objects.Object_Key;

   Null_Tagged_Entity : constant Tagged_Entity_Ref;
   function "=" (Left, Right : Tagged_Entity_Ref'Class) return Boolean;

   --  Set the tag entity identifier
   procedure Set_Id (Object : in out Tagged_Entity_Ref;
                     Value  : in ADO.Identifier);

   --  Get the tag entity identifier
   function Get_Id (Object : in Tagged_Entity_Ref)
                 return ADO.Identifier;

   --  Set Title: Tag model
   --  Date: 2013-02-23the database entity to which the tag is associated
   procedure Set_For_Entity_Id (Object : in out Tagged_Entity_Ref;
                                Value  : in ADO.Identifier);

   --  Get Title: Tag model
   --  Date: 2013-02-23the database entity to which the tag is associated
   function Get_For_Entity_Id (Object : in Tagged_Entity_Ref)
                 return ADO.Identifier;

   --  Set the entity type
   procedure Set_Entity_Type (Object : in out Tagged_Entity_Ref;
                              Value  : in ADO.Entity_Type);

   --  Get the entity type
   function Get_Entity_Type (Object : in Tagged_Entity_Ref)
                 return ADO.Entity_Type;

   --
   procedure Set_Tag (Object : in out Tagged_Entity_Ref;
                      Value  : in AWA.Tags.Models.Tag_Ref'Class);

   --
   function Get_Tag (Object : in Tagged_Entity_Ref)
                 return AWA.Tags.Models.Tag_Ref'Class;

   --  Load the entity identified by 'Id'.
   --  Raises the NOT_FOUND exception if it does not exist.
   procedure Load (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier);

   --  Load the entity identified by 'Id'.
   --  Returns True in Found if the object was found and False if it does not exist.
   procedure Load (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Id      : in ADO.Identifier;
                   Found   : out Boolean);

   --  Find and load the entity.
   overriding
   procedure Find (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   --  Save the entity.  If the entity does not have an identifier, an identifier is allocated
   --  and it is inserted in the table.  Otherwise, only data fields which have been changed
   --  are updated.
   overriding
   procedure Save (Object  : in out Tagged_Entity_Ref;
                   Session : in out ADO.Sessions.Master_Session'Class);

   --  Delete the entity.
   overriding
   procedure Delete (Object  : in out Tagged_Entity_Ref;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   function Get_Value (From : in Tagged_Entity_Ref;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Table definition
   TAGGED_ENTITY_TABLE : constant ADO.Schemas.Class_Mapping_Access;

   --  Internal method to allocate the Object_Record instance
   overriding
   procedure Allocate (Object : in out Tagged_Entity_Ref);

   --  Copy of the object.
   procedure Copy (Object : in Tagged_Entity_Ref;
                   Into   : in out Tagged_Entity_Ref);

   package Tagged_Entity_Vectors is
      new Ada.Containers.Vectors (Index_Type   => Natural,
                                  Element_Type => Tagged_Entity_Ref,
                                  "="          => "=");
   subtype Tagged_Entity_Vector is Tagged_Entity_Vectors.Vector;

   procedure List (Object  : in out Tagged_Entity_Vector;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class);

   Query_Check_Tag : constant ADO.Queries.Query_Definition_Access;

   Query_Tag_List : constant ADO.Queries.Query_Definition_Access;

private
   TAG_NAME : aliased constant String := "awa_tag";
   COL_0_1_NAME : aliased constant String := "id";
   COL_1_1_NAME : aliased constant String := "name";

   TAG_DEF : aliased constant ADO.Schemas.Class_Mapping :=
     (Count => 2,
      Table => TAG_NAME'Access,
      Members => (
         1 => COL_0_1_NAME'Access,
         2 => COL_1_1_NAME'Access
)
     );
   TAG_TABLE : constant ADO.Schemas.Class_Mapping_Access
      := TAG_DEF'Access;

   Null_Tag : constant Tag_Ref
      := Tag_Ref'(ADO.Objects.Object_Ref with others => <>);

   type Tag_Impl is
      new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                     Of_Class => TAG_DEF'Access)
   with record
       Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Tag_Access is access all Tag_Impl;

   overriding
   procedure Destroy (Object : access Tag_Impl);

   overriding
   procedure Find (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Session'Class);
   procedure Load (Object  : in out Tag_Impl;
                   Stmt    : in out ADO.Statements.Query_Statement'Class;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Tag_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   procedure Create (Object  : in out Tag_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Tag_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   procedure Set_Field (Object : in out Tag_Ref'Class;
                        Impl   : out Tag_Access);
   TAGGED_ENTITY_NAME : aliased constant String := "awa_tagged_entity";
   COL_0_2_NAME : aliased constant String := "id";
   COL_1_2_NAME : aliased constant String := "for_entity_id";
   COL_2_2_NAME : aliased constant String := "entity_type";
   COL_3_2_NAME : aliased constant String := "tag_id";

   TAGGED_ENTITY_DEF : aliased constant ADO.Schemas.Class_Mapping :=
     (Count => 4,
      Table => TAGGED_ENTITY_NAME'Access,
      Members => (
         1 => COL_0_2_NAME'Access,
         2 => COL_1_2_NAME'Access,
         3 => COL_2_2_NAME'Access,
         4 => COL_3_2_NAME'Access
)
     );
   TAGGED_ENTITY_TABLE : constant ADO.Schemas.Class_Mapping_Access
      := TAGGED_ENTITY_DEF'Access;

   Null_Tagged_Entity : constant Tagged_Entity_Ref
      := Tagged_Entity_Ref'(ADO.Objects.Object_Ref with others => <>);

   type Tagged_Entity_Impl is
      new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                     Of_Class => TAGGED_ENTITY_DEF'Access)
   with record
       For_Entity_Id : ADO.Identifier;
       Entity_Type : ADO.Entity_Type;
       Tag : AWA.Tags.Models.Tag_Ref;
   end record;

   type Tagged_Entity_Access is access all Tagged_Entity_Impl;

   overriding
   procedure Destroy (Object : access Tagged_Entity_Impl);

   overriding
   procedure Find (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Session'Class);
   procedure Load (Object  : in out Tagged_Entity_Impl;
                   Stmt    : in out ADO.Statements.Query_Statement'Class;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Tagged_Entity_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   procedure Create (Object  : in out Tagged_Entity_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Tagged_Entity_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   procedure Set_Field (Object : in out Tagged_Entity_Ref'Class;
                        Impl   : out Tagged_Entity_Access);

   package File_1 is
      new ADO.Queries.Loaders.File (Path => "tag-queries.xml",
                                    Sha1 => "9B2B599473F75F92CB5AB5045675E4CCEF926543");

   package Def_Check_Tag is
      new ADO.Queries.Loaders.Query (Name => "check-tag",
                                     File => File_1.File'Access);
   Query_Check_Tag : constant ADO.Queries.Query_Definition_Access
   := Def_Check_Tag.Query'Access;

   package Def_Tag_List is
      new ADO.Queries.Loaders.Query (Name => "tag-list",
                                     File => File_1.File'Access);
   Query_Tag_List : constant ADO.Queries.Query_Definition_Access
   := Def_Tag_List.Query'Access;
end AWA.Tags.Models;

Rebuild the model files

Rebuild the model files


-----------------------------------------------------------------------
--  ado-drivers-tests -- Unit tests for database drivers
--  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.Tests;
package ADO.Drivers.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

end ADO.Drivers.Tests;

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

with Util.Tests;
package ADO.Drivers.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

   --  Test the Set_Connection procedure with several error cases.
   procedure Test_Set_Connection_Error (T : in out Test);

end ADO.Drivers.Tests;

Declare the Test_Set_Connection_Error test procedure


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

package Druss.Commands.Status is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type);

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Status;

-----------------------------------------------------------------------
--  druss-commands-status -- Druss status commands
--  Copyright (C) 2017, 2018, 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.
-----------------------------------------------------------------------

package Druss.Commands.Status is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type);

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Status;

Change Help command to accept in out command


-----------------------------------------------------------------------
--  mat-readers-streams -- Reader for streams
--  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.Streams.Buffered;
package MAT.Readers.Streams is

   type Stream_Reader_Type is new Manager_Base with private;

   --  Read the events from the stream and stop when the end of the stream is reached.
   procedure Read_All (Reader : in out Stream_Reader_Type);

   --  Read a message from the stream.
   overriding
   procedure Read_Message (Reader : in out Stream_Reader_Type;
                           Msg    : in out Message);

private

   type Stream_Reader_Type is new Manager_Base with record
      Stream : Util.Streams.Buffered.Buffered_Stream;
   end record;

end MAT.Readers.Streams;

-----------------------------------------------------------------------
--  mat-readers-streams -- Reader for streams
--  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.Streams.Buffered;
package MAT.Readers.Streams is

   type Stream_Reader_Type is new Manager_Base with private;

   --  Read the events from the stream and stop when the end of the stream is reached.
   procedure Read_All (Reader : in out Stream_Reader_Type);

   --  Read a message from the stream.
   overriding
   procedure Read_Message (Reader : in out Stream_Reader_Type;
                           Msg    : in out Message);

private

   type Stream_Reader_Type is new Manager_Base with record
      Stream : Util.Streams.Buffered.Buffered_Stream;
      Data   : Util.Streams.Buffered.Buffer_Access;
   end record;

end MAT.Readers.Streams;

Add the data buffer in the Stream_Reader_Type type


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

   use Util.Log;
   use Util.Concurrent.Counters;

   Log  : constant Loggers.Logger := Loggers.Create ("multipro");

   --  Target counter value we would like.
   Max_Counter       : constant Integer := 1_000_000;

   --  Max number of tasks for executing the concurrent increment.
   Max_Tasks         : constant Integer := 16;

   --  Performance measurement.
   Perf    : Util.Measures.Measure_Set;
   T       : Util.Measures.Stamp;
begin
   for Task_Count in 1 .. Max_Tasks loop
      declare
         --  Each task will increment the counter by the following amount.
         Increment_By_Task : constant Integer := Max_Counter / Task_Count;

         --  Counter not protected for concurrency access.
         Unsafe  : Integer := 0;

         --  Counter protected by concurrent accesses.
         Counter : Util.Concurrent.Counters.Counter;
      begin
         declare
            --  A task that increments the shared counter Unsafe and Counter by
            --  the specified amount.
            task type Worker is
               entry Start (Count : in Natural);
            end Worker;

            task body Worker is
               Cnt : Natural;
            begin
               accept Start (Count : in Natural) do
                  Cnt := Count;
               end;
               --  Increment the two counters as many times as necessary.
               for I in 1 .. Cnt loop
                  Util.Concurrent.Counters.Increment (Counter);
                  Unsafe := Unsafe + 1;
               end loop;
            end Worker;

            type Worker_Array is array (1 .. Task_Count) of Worker;

            Tasks : Worker_Array;

         begin
            Log.Info ("Starting " & Integer'Image (Task_Count) & " tasks");
            for I in Tasks'Range loop
               Tasks (I).Start (Increment_By_Task);
            end loop;

            --  Leaving the Worker task scope means we are waiting for our tasks to finish.
         end;

         Util.Measures.Report (Measures => Perf,
                               S        => T,
                               Title    => "Increment counter with "
                               & Integer'Image (Task_Count) & " tasks");

         --  Unsafe will be equal to Counter if Task_Count = 1 or if the host is mono-processor.
         --  On dual/quad core, the Unsafe value becomes random and gets lower each time
         --  the number of tasks increases.
         Log.Info ("Expected value at the end      : " & Integer'Image (Increment_By_Task * Task_Count));
         Log.Info ("Counter value at the end       : " & Integer'Image (Value (Counter)));
         Log.Info ("Unprotected counter at the end : " & Integer'Image (Unsafe));
      end;
   end loop;

   --  Dump the result
   Util.Measures.Write (Perf, "Multipro", Ada.Text_IO.Standard_Output);
end Multipro;

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

   use Util.Log;
   use Util.Concurrent.Counters;

   Log  : constant Loggers.Logger := Loggers.Create ("multipro");

   --  Target counter value we would like.
   Max_Counter       : constant Integer := 10_000_000;

   --  Max number of tasks for executing the concurrent increment.
   Max_Tasks         : constant Integer := 16;

   --  Performance measurement.
   Perf    : Util.Measures.Measure_Set;
   T       : Util.Measures.Stamp;
begin
   for Task_Count in 1 .. Max_Tasks loop
      declare
         --  Each task will increment the counter by the following amount.
         Increment_By_Task : constant Integer := Max_Counter / Task_Count;

         --  Counter not protected for concurrency access.
         Unsafe  : Integer := 0;

         --  Counter protected by concurrent accesses.
         Counter : Util.Concurrent.Counters.Counter;
      begin
         declare
            --  A task that increments the shared counter Unsafe and Counter by
            --  the specified amount.
            task type Worker is
               entry Start (Count : in Natural);
            end Worker;

            task body Worker is
               Cnt : Natural;
            begin
               accept Start (Count : in Natural) do
                  Cnt := Count;
               end;
               --  Increment the two counters as many times as necessary.
               for I in 1 .. Cnt loop
                  Util.Concurrent.Counters.Increment (Counter);
                  Unsafe := Unsafe + 1;
               end loop;
            end Worker;

            type Worker_Array is array (1 .. Task_Count) of Worker;

            Tasks : Worker_Array;

         begin
            Log.Info ("Starting " & Integer'Image (Task_Count) & " tasks");
            for I in Tasks'Range loop
               Tasks (I).Start (Increment_By_Task);
            end loop;

            --  Leaving the Worker task scope means we are waiting for our tasks to finish.
         end;

         Util.Measures.Report (Measures => Perf,
                               S        => T,
                               Title    => "Increment counter with "
                               & Integer'Image (Task_Count) & " tasks");

         --  Unsafe will be equal to Counter if Task_Count = 1 or if the host is mono-processor.
         --  On dual/quad core, the Unsafe value becomes random and gets lower each time
         --  the number of tasks increases.
         Log.Info ("Expected value at the end      : " & Integer'Image (Increment_By_Task * Task_Count));
         Log.Info ("Counter value at the end       : " & Integer'Image (Value (Counter)));
         Log.Info ("Unprotected counter at the end : " & Integer'Image (Unsafe));
      end;
   end loop;

   --  Dump the result
   Util.Measures.Write (Perf, "Multipro", Ada.Text_IO.Standard_Output);
end Multipro;

Increase counter value

Increase counter value


-----------------------------------------------------------------------
--  gen-artifacts-mappings -- Type mapping artifact for Code Generator
--  Copyright (C) 2011, 2012, 2015, 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 Ada.Strings.Unbounded;

with Util.Log.Loggers;
with Gen.Utils;
with Gen.Model;
with Gen.Model.Mappings;

--  The Gen.Artifacts.Mappings package is an artifact to map XML-based types
--  into Ada types.
package body Gen.Artifacts.Mappings is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is

      use Ada.Strings.Unbounded;

      procedure Register_Mapping (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node);

      procedure Register_Mappings (Model : in out Gen.Model.Packages.Model_Definition;
                                   Node  : in DOM.Core.Node);

      --  ------------------------------
      --  Register a new type mapping.
      --  ------------------------------
      procedure Register_Mapping (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node) is

         procedure Register_Type (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node);

         N          : constant DOM.Core.Node := Gen.Utils.Get_Child (Node, "to");
         To         : constant String := Gen.Utils.Get_Data_Content (N);
         Kind       : constant String := To_String (Gen.Utils.Get_Attribute (Node, "type"));
         Allow_Null : constant Boolean := Gen.Utils.Get_Attribute (Node, "allow-null", False);
         Kind_Type  : Gen.Model.Mappings.Basic_Type;

         procedure Register_Type (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node) is
            pragma Unreferenced (O);

            From : constant String := Gen.Utils.Get_Data_Content (Node);
         begin
            Gen.Model.Mappings.Register_Type (Target => To,
                                              From   => From,
                                              Kind   => Kind_Type,
                                              Allow_Null => Allow_Null);
         end Register_Type;

         procedure Iterate is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                        Process => Register_Type);

      begin
         if Kind = "date" or To = "Ada.Calendar.Time" then
            Kind_Type := Gen.Model.Mappings.T_DATE;

         elsif Kind = "identifier" or To = "ADO.Identifier" then
            Kind_Type := Gen.Model.Mappings.T_IDENTIFIER;

         elsif Kind = "boolean" then
            Kind_Type := Gen.Model.Mappings.T_BOOLEAN;

         elsif Kind = "string" or To = "Ada.Strings.Unbounded.Unbounded_String" then
            Kind_Type := Gen.Model.Mappings.T_STRING;

         elsif Kind = "blob" or To = "ADO.Blob_Ref" then
            Kind_Type := Gen.Model.Mappings.T_BLOB;

         else
            Kind_Type := Gen.Model.Mappings.T_INTEGER;
         end if;
         Iterate (O, Node, "from");
      end Register_Mapping;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mappings (Model : in out Gen.Model.Packages.Model_Definition;
                                   Node  : in DOM.Core.Node) is
         procedure Iterate is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                        Process => Register_Mapping);

         Name : constant String := Gen.Utils.Get_Attribute (Node, "name");
      begin
         Gen.Model.Mappings.Set_Mapping_Name (Name);
         Iterate (Model, Node, "mapping");
      end Register_Mappings;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mappings);
   begin
      Log.Debug ("Initializing mapping artifact for the configuration");

      Gen.Artifacts.Artifact (Handler).Initialize (Path, Node, Model, Context);
      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "mappings");
   end Initialize;

end Gen.Artifacts.Mappings;

-----------------------------------------------------------------------
--  gen-artifacts-mappings -- Type mapping artifact for Code Generator
--  Copyright (C) 2011, 2012, 2015, 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 Ada.Strings.Unbounded;

with Util.Log.Loggers;
with Gen.Utils;
with Gen.Model;
with Gen.Model.Mappings;

--  The Gen.Artifacts.Mappings package is an artifact to map XML-based types
--  into Ada types.
package body Gen.Artifacts.Mappings is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is

      use Ada.Strings.Unbounded;

      procedure Register_Mapping (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node);

      procedure Register_Mappings (Model : in out Gen.Model.Packages.Model_Definition;
                                   Node  : in DOM.Core.Node);

      --  ------------------------------
      --  Register a new type mapping.
      --  ------------------------------
      procedure Register_Mapping (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node) is

         procedure Register_Type (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node);

         N          : constant DOM.Core.Node := Gen.Utils.Get_Child (Node, "to");
         To         : constant String := Gen.Utils.Get_Data_Content (N);
         Kind       : constant String := To_String (Gen.Utils.Get_Attribute (Node, "type"));
         Allow_Null : constant Boolean := Gen.Utils.Get_Attribute (Node, "allow-null", False);
         Kind_Type  : Gen.Model.Mappings.Basic_Type;

         procedure Register_Type (O    : in out Gen.Model.Packages.Model_Definition;
                                  Node : in DOM.Core.Node) is
            pragma Unreferenced (O);

            From : constant String := Gen.Utils.Get_Data_Content (Node);
         begin
            Gen.Model.Mappings.Register_Type (Target => To,
                                              From   => From,
                                              Kind   => Kind_Type,
                                              Allow_Null => Allow_Null);
         end Register_Type;

         procedure Iterate is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                        Process => Register_Type);

      begin
         if Kind = "date" or To = "Ada.Calendar.Time" then
            Kind_Type := Gen.Model.Mappings.T_DATE;

         elsif Kind = "identifier" or To = "ADO.Identifier" then
            Kind_Type := Gen.Model.Mappings.T_IDENTIFIER;

         elsif Kind = "boolean" then
            Kind_Type := Gen.Model.Mappings.T_BOOLEAN;

         elsif Kind = "string" or To = "Ada.Strings.Unbounded.Unbounded_String" then
            Kind_Type := Gen.Model.Mappings.T_STRING;

         elsif Kind = "blob" or To = "ADO.Blob_Ref" then
            Kind_Type := Gen.Model.Mappings.T_BLOB;

         elsif Kind = "entity_type" or To = "ADO.Entity_Type" then
            Kind_Type := Gen.Model.Mappings.T_ENTITY_TYPE;

         else
            Kind_Type := Gen.Model.Mappings.T_INTEGER;
         end if;
         Iterate (O, Node, "from");
      end Register_Mapping;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mappings (Model : in out Gen.Model.Packages.Model_Definition;
                                   Node  : in DOM.Core.Node) is
         procedure Iterate is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                        Process => Register_Mapping);

         Name : constant String := Gen.Utils.Get_Attribute (Node, "name");
      begin
         Gen.Model.Mappings.Set_Mapping_Name (Name);
         Iterate (Model, Node, "mapping");
      end Register_Mappings;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mappings);
   begin
      Log.Debug ("Initializing mapping artifact for the configuration");

      Gen.Artifacts.Artifact (Handler).Initialize (Path, Node, Model, Context);
      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "mappings");
   end Initialize;

end Gen.Artifacts.Mappings;

Handle type 'entity_type' in the XML mapping


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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Strings;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

--  == URL Security Policy ==
--  The <tt>Security.Policies.Urls</tt> implements a security policy intended to be used
--  in web servers.  It allows to protect an URL by defining permissions that must be granted
--  for a user to get access to the URL.  A typical example is a web server that has a set of
--  administration pages, these pages should be accessed by users having some admin permission.
--
--  === Policy creation ===
--  An instance of the <tt>URL_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Urls.URL_Policy_Access;
--
--  Create the URL policy and register it in the policy manager as follows:
--
--    Policy := new URL_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  Once the URL policy is registered, the policy manager can read and process the following
--  XML configuration:
--
--    <policy-rules>
--      <url-policy id='1'>
--        <permission>create-workspace</permission>
--        <permission>admin</permission>
--        <url-pattern>/workspace/create</url-pattern>
--        <url-pattern>/workspace/setup/*</url-pattern>
--      </url-policy>
--      ...
--    </policy-rules>
--
--  This policy gives access to the URL that match one of the URL pattern if the
--  security context has the permission create-workspace or admin.
--  These two permissions are checked according to another security policy.
--  The XML configuration can define several <tt>url-policy</tt>.  They are checked in
--  the order defined in the XML.  In other words, the first <tt>url-policy</tt> that matches
--  the URL is used to verify the permission.
--
--  The <tt>url-policy</tt> definition can contain several <tt>permission</tt>.
--  The first permission that is granted gives access to the URL.
--
--  === Checking for permission ===
--  To check a URL permission, you must declare a <tt>URI_Permission</tt> object with the URL.
--
--     URI    : constant String := ...;
--     Perm   : constant Policies.URLs.URI_Permission (URI'Length)
--               := URI_Permission '(Len => URI'Length, URI => URI);
--
--  Then, we can check the permission:
--
--     Result : Boolean := Security.Contexts.Has_Permission (Perm);
--
package Security.Policies.Urls is

   NAME : constant String := "URL-Policy";

   package P_URL is new Security.Permissions.Definition ("url");

   --  ------------------------------
   --  URI Permission
   --  ------------------------------
   --  Represents a permission to access a given URI.
   type URI_Permission (Len : Natural) is new Permissions.Permission (P_URL.Permission) with record
      URI : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out URL_Policy);

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access;

private

   use Util.Strings;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
      Id           : Natural := 0;
      Permissions  : Util.Beans.Objects.Vectors.Vector;
      Patterns     : Util.Beans.Objects.Vectors.Vector;
   end record;

end Security.Policies.Urls;

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

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Strings;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

--  == URL Security Policy ==
--  The <tt>Security.Policies.Urls</tt> implements a security policy intended to be used
--  in web servers.  It allows to protect an URL by defining permissions that must be granted
--  for a user to get access to the URL.  A typical example is a web server that has a set of
--  administration pages, these pages should be accessed by users having some admin permission.
--
--  === Policy creation ===
--  An instance of the <tt>URL_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Urls.URL_Policy_Access;
--
--  Create the URL policy and register it in the policy manager as follows:
--
--    Policy := new URL_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  Once the URL policy is registered, the policy manager can read and process the following
--  XML configuration:
--
--    <policy-rules>
--      <url-policy id='1'>
--        <permission>create-workspace</permission>
--        <permission>admin</permission>
--        <url-pattern>/workspace/create</url-pattern>
--        <url-pattern>/workspace/setup/*</url-pattern>
--      </url-policy>
--      ...
--    </policy-rules>
--
--  This policy gives access to the URL that match one of the URL pattern if the
--  security context has the permission create-workspace or admin.
--  These two permissions are checked according to another security policy.
--  The XML configuration can define several <tt>url-policy</tt>.  They are checked in
--  the order defined in the XML.  In other words, the first <tt>url-policy</tt> that matches
--  the URL is used to verify the permission.
--
--  The <tt>url-policy</tt> definition can contain several <tt>permission</tt>.
--  The first permission that is granted gives access to the URL.
--
--  === Checking for permission ===
--  To check a URL permission, you must declare a <tt>URL_Permission</tt> object with the URL.
--
--     URL    : constant String := ...;
--     Perm   : constant Policies.URLs.URL_Permission (URL'Length)
--               := URL_Permission '(Len => URI'Length, URL => URL);
--
--  Then, we can check the permission:
--
--     Result : Boolean := Security.Contexts.Has_Permission (Perm);
--
package Security.Policies.URLs is

   NAME : constant String := "URL-Policy";

   package P_URL is new Security.Permissions.Definition ("url");

   --  ------------------------------
   --  URL Permission
   --  ------------------------------
   --  Represents a permission to access a given URL.
   type URL_Permission (Len : Natural) is new Permissions.Permission (P_URL.Permission) with record
      URL : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URL_Permission'Class) return Boolean;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out URL_Policy);

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access;

private

   use Util.Strings;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
      Id           : Natural := 0;
      Permissions  : Util.Beans.Objects.Vectors.Vector;
      Patterns     : Util.Beans.Objects.Vectors.Vector;
   end record;

end Security.Policies.URLs;

Rename package URLs and the permission URL_Permission


-----------------------------------------------------------------------
--  wiki-documents -- Wiki document
--  Copyright (C) 2011, 2015, 2016, 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 Wiki.Strings;
with Wiki.Attributes;
with Wiki.Nodes;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.  The <tt>Document</tt> holds two distinct parts:
--
--  * A main document body that represents the Wiki content that was parsed.
--  * A table of contents part that was built while Wiki sections are collected.
--
--  Most of the operations provided by the <tt>Wiki.Documents</tt> package are intended to
--  be used by the wiki parser and filters to build the document.  The document is made of
--  nodes whose knowledge is required by the renderer.
--
--  A document instance must be declared before parsing a text:
--
--     Doc    : Wiki.Documents.Document;
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Returns True if the current node is the root document node.
   function Is_Root_Node (Doc : in Document) return Boolean;

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add 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 Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

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

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Returns True if the document is empty.
   function Is_Empty (Doc : in Document) return Boolean;

   --  Returns True if the document displays the table of contents by itself.
   function Is_Using_TOC (Doc : in Document) return Boolean;

   --  Returns True if the table of contents is visible and must be rendered.
   function Is_Visible_TOC (Doc : in Document) return Boolean;

   --  Hide the table of contents.
   procedure Hide_TOC (Doc : in out Document);

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes       : Wiki.Nodes.Node_List_Ref;
      TOC         : Wiki.Nodes.Node_List_Ref;
      Current     : Wiki.Nodes.Node_Type_Access;
      Using_TOC   : Boolean := False;
      Visible_TOC : Boolean := True;
   end record;

end Wiki.Documents;

-----------------------------------------------------------------------
--  wiki-documents -- Wiki document
--  Copyright (C) 2011, 2015, 2016, 2018, 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.Strings;
with Wiki.Attributes;
with Wiki.Nodes.Lists;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.  The <tt>Document</tt> holds two distinct parts:
--
--  * A main document body that represents the Wiki content that was parsed.
--  * A table of contents part that was built while Wiki sections are collected.
--
--  Most of the operations provided by the <tt>Wiki.Documents</tt> package are intended to
--  be used by the wiki parser and filters to build the document.  The document is made of
--  nodes whose knowledge is required by the renderer.
--
--  A document instance must be declared before parsing a text:
--
--     Doc    : Wiki.Documents.Document;
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Returns True if the current node is the root document node.
   function Is_Root_Node (Doc : in Document) return Boolean;

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add 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 Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

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

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Returns True if the document is empty.
   function Is_Empty (Doc : in Document) return Boolean;

   --  Returns True if the document displays the table of contents by itself.
   function Is_Using_TOC (Doc : in Document) return Boolean;

   --  Returns True if the table of contents is visible and must be rendered.
   function Is_Visible_TOC (Doc : in Document) return Boolean;

   --  Hide the table of contents.
   procedure Hide_TOC (Doc : in out Document);

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Lists.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Lists.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes       : Wiki.Nodes.Lists.Node_List_Ref;
      TOC         : Wiki.Nodes.Lists.Node_List_Ref;
      Current     : Wiki.Nodes.Node_Type_Access;
      Using_TOC   : Boolean := False;
      Visible_TOC : Boolean := True;
   end record;

end Wiki.Documents;

Update to use the new Node_List_Ref reference