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

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Permission (Id : Permission_Index) is abstract tagged limited null record;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

end Security.Permissions;

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

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   Invalid_Name : exception;

   type Permission_Index is new Natural;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Permission (Id : Permission_Index) is tagged limited null record;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

end Security.Permissions;

Make the Permission type not abstract

Make the Permission type not abstract


-----------------------------------------------------------------------
--  concurrency.tests -- Unit tests for concurrency package
--  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 Util.Tests;

package Util.Concurrent.Tests is

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

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

   procedure Test_Increment (T : in out Test);
   procedure Test_Decrement (T : in out Test);
   procedure Test_Decrement_And_Test (T : in out Test);

   procedure Test_Copy (T : in out Test);

   --  Test concurrent pool
   procedure Test_Pool (T : in out Test);

   --  Test concurrent pool
   procedure Test_Concurrent_Pool (T : in out Test);

   --  Test fifo.
   procedure Test_Fifo (T : in out Test);

   --  Test concurrent aspects of fifo.
   procedure Test_Concurrent_Fifo (T : in out Test);

   --  Test concurrent arrays.
   procedure Test_Array (T : in out Test);

end Util.Concurrent.Tests;

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

with Util.Tests;

package Util.Concurrent.Tests is

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

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

   procedure Test_Increment (T : in out Test);
   procedure Test_Decrement (T : in out Test);
   procedure Test_Decrement_And_Test (T : in out Test);

   procedure Test_Copy (T : in out Test);

   --  Test concurrent pool
   procedure Test_Pool (T : in out Test);

   --  Test concurrent pool
   procedure Test_Concurrent_Pool (T : in out Test);

   --  Test fifo.
   procedure Test_Fifo (T : in out Test);

   --  Test concurrent aspects of fifo.
   procedure Test_Concurrent_Fifo (T : in out Test);

   --  Test concurrent arrays.
   procedure Test_Array (T : in out Test);

   --  Test concurrent sequences.
   procedure Test_Concurrent_Sequences (T : in out Test);

end Util.Concurrent.Tests;

Declare Test_Concurrent_Sequences procedure to test the sequences


-----------------------------------------------------------------------
--  ADO Objects -- Database objects
--  Copyright (C) 2009, 2010 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;

package body ADO.Objects is

   use Util.Log;

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

   --  ------------------------------
   --  Compute the hash of the object key.
   --  ------------------------------
   function Hash (Key : Object_Key) return Ada.Containers.Hash_Type is
      Result : Ada.Containers.Hash_Type;
   begin
      --  @todo SCz 2010-08-03: hash on the object type/class/table
      case Key.Of_Type is
         when KEY_INTEGER =>
            Result := Ada.Containers.Hash_Type (Key.Id);

         when KEY_STRING =>
            Result := 0;

      end case;
      return Result;
   end Hash;

   --  ------------------------------
   --  Compare whether the two objects pointed to by Left and Right have the same
   --  object key.
   --  ------------------------------
   function Equivalent_Elements (Left, Right : Object_Key)
                                 return Boolean is
      use Ada.Strings.Unbounded;
   begin
      if Left.Of_Type /= Right.Of_Type then
         return False;
      end if;
      case Left.Of_Type is
         when KEY_INTEGER =>
            return Left.Id = Right.Id;

         when KEY_STRING =>
            return Left.Str = Right.Str;

      end case;
   end Equivalent_Elements;

   procedure Adjust (Object : in out Object_Ref) is
   begin
      if Object.Object /= null then
         Util.Concurrent.Counters.Increment (Object.Object.Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Object_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Object /= null then
         Util.Concurrent.Counters.Decrement (Object.Object.Counter, Is_Zero);
         if Is_Zero then
            Destroy (Object.Object);
            Object.Object := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Mark the field identified by Field as modified.
   --  ------------------------------
   procedure Set_Field (Object : in out Object_Ref'Class;
                        Field  : in Positive) is
   begin
      if Object.Object = null then
         Object.Allocate;
      end if;
      Object.Object.Modified (Field) := True;
   end Set_Field;

   --  ------------------------------
   --  Check whether this object is initialized or not.
   --  ------------------------------
   function Is_Null (Object : in Object_Ref'Class) return Boolean is
   begin
      return Object.Object = null;
   end Is_Null;

   --  ------------------------------
   --  Internal method to get the object record instance.
   --  ------------------------------
   function Get_Object (Ref : in Object_Ref'Class) return Object_Record_Access is
   begin
      return Ref.Object;
   end Get_Object;

   --  ------------------------------
   --  Check if the two objects are the same database objects.
   --  The comparison is only made on the primary key.
   --  Returns true if the two objects have the same primary key.
   --  ------------------------------
   function "=" (Left : Object_Ref'Class; Right : Object_Ref'Class) return Boolean is
   begin
      --  Same target object
      if Left.Object = Right.Object then
         return True;
      end if;
      --  One of the target object is null
      if Left.Object = null or Right.Object = null then
         return False;
      end if;
      return Left.Object.Key = Right.Object.Key;
   end "=";

   procedure Set_Object (Ref : in out Object_Ref'Class;
                         Object : in Object_Record_Access) is
      Is_Zero : Boolean;
   begin
      if Ref.Object /= null and Ref.Object /= Object then
         Util.Concurrent.Counters.Decrement (Ref.Object.Counter, Is_Zero);
         if Is_Zero then
            Destroy (Ref.Object);
         end if;
      end if;
      Ref.Object := Object;
   end Set_Object;

   --  ------------------------------
   --  Get the object key
   --  ------------------------------
   function Get_Id (Ref : in Object_Record'Class) return Object_Key is
   begin
      return Ref.Key;
   end Get_Id;

   --  ------------------------------
   --  Check if this is a new object.
   --  Returns True if an insert is necessary to persist this object.
   --  ------------------------------
   function Is_Created (Ref : in Object_Record'Class) return Boolean is
   begin
      return Ref.Is_Created;
   end Is_Created;

   --  ------------------------------
   --  Mark the object as created in the database.
   --  ------------------------------
   procedure Set_Created (Ref : in out Object_Record'Class) is
   begin
      Ref.Is_Created := True;
   end Set_Created;

   --  ------------------------------
   --  Check if the field at position Field was modified.
   --  ------------------------------
   function Is_Modified (Ref   : in Object_Record'Class;
                         Field : in Positive) return Boolean is
   begin
      return Ref.Modified (Field);
   end Is_Modified;

   --  ------------------------------
   --  Clear the modification flag associated with the field at
   --  position Field.
   --  ------------------------------
   procedure Clear_Modified (Ref   : in out Object_Record'Class;
                             Field : in Positive) is
   begin
      Ref.Modified (Field) := False;
   end Clear_Modified;

end ADO.Objects;

-----------------------------------------------------------------------
--  ADO Objects -- Database objects
--  Copyright (C) 2009, 2010 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;

package body ADO.Objects is

   use Util.Log;

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

   --  ------------------------------
   --  Compute the hash of the object key.
   --  ------------------------------
   function Hash (Key : Object_Key) return Ada.Containers.Hash_Type is
      Result : Ada.Containers.Hash_Type;
   begin
      --  @todo SCz 2010-08-03: hash on the object type/class/table
      case Key.Of_Type is
         when KEY_INTEGER =>
            Result := Ada.Containers.Hash_Type (Key.Id);

         when KEY_STRING =>
            Result := 0;

      end case;
      return Result;
   end Hash;

   --  ------------------------------
   --  Compare whether the two objects pointed to by Left and Right have the same
   --  object key.
   --  ------------------------------
   function Equivalent_Elements (Left, Right : Object_Key)
                                 return Boolean is
      use Ada.Strings.Unbounded;
   begin
      if Left.Of_Type /= Right.Of_Type then
         return False;
      end if;
      case Left.Of_Type is
         when KEY_INTEGER =>
            return Left.Id = Right.Id;

         when KEY_STRING =>
            return Left.Str = Right.Str;

      end case;
   end Equivalent_Elements;

   --  ------------------------------
   --  Increment the reference counter when an object is copied
   --  ------------------------------
   procedure Adjust (Object : in out Object_Ref) is
   begin
      if Object.Object /= null then
         Util.Concurrent.Counters.Increment (Object.Object.Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Object_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Object /= null then
         Util.Concurrent.Counters.Decrement (Object.Object.Counter, Is_Zero);
         if Is_Zero then
            Destroy (Object.Object);
            Object.Object := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Mark the field identified by Field as modified.
   --  ------------------------------
   procedure Set_Field (Object : in out Object_Ref'Class;
                        Field  : in Positive) is
   begin
      if Object.Object = null then
         Object.Allocate;
      end if;
      Object.Object.Modified (Field) := True;
   end Set_Field;

   --  ------------------------------
   --  Check whether this object is initialized or not.
   --  ------------------------------
   function Is_Null (Object : in Object_Ref'Class) return Boolean is
   begin
      return Object.Object = null;
   end Is_Null;

   --  ------------------------------
   --  Internal method to get the object record instance.
   --  ------------------------------
   function Get_Object (Ref : in Object_Ref'Class) return Object_Record_Access is
   begin
      return Ref.Object;
   end Get_Object;

   --  ------------------------------
   --  Check if the two objects are the same database objects.
   --  The comparison is only made on the primary key.
   --  Returns true if the two objects have the same primary key.
   --  ------------------------------
   function "=" (Left : Object_Ref'Class; Right : Object_Ref'Class) return Boolean is
   begin
      --  Same target object
      if Left.Object = Right.Object then
         return True;
      end if;
      --  One of the target object is null
      if Left.Object = null or Right.Object = null then
         return False;
      end if;
      return Left.Object.Key = Right.Object.Key;
   end "=";

   procedure Set_Object (Ref : in out Object_Ref'Class;
                         Object : in Object_Record_Access) is
      Is_Zero : Boolean;
   begin
      if Ref.Object /= null and Ref.Object /= Object then
         Util.Concurrent.Counters.Decrement (Ref.Object.Counter, Is_Zero);
         if Is_Zero then
            Destroy (Ref.Object);
         end if;
      end if;
      Ref.Object := Object;
   end Set_Object;

   --  ------------------------------
   --  Get the object key
   --  ------------------------------
   function Get_Id (Ref : in Object_Record'Class) return Object_Key is
   begin
      return Ref.Key;
   end Get_Id;

   --  ------------------------------
   --  Check if this is a new object.
   --  Returns True if an insert is necessary to persist this object.
   --  ------------------------------
   function Is_Created (Ref : in Object_Record'Class) return Boolean is
   begin
      return Ref.Is_Created;
   end Is_Created;

   --  ------------------------------
   --  Mark the object as created in the database.
   --  ------------------------------
   procedure Set_Created (Ref : in out Object_Record'Class) is
   begin
      Ref.Is_Created := True;
   end Set_Created;

   --  ------------------------------
   --  Check if the field at position Field was modified.
   --  ------------------------------
   function Is_Modified (Ref   : in Object_Record'Class;
                         Field : in Positive) return Boolean is
   begin
      return Ref.Modified (Field);
   end Is_Modified;

   --  ------------------------------
   --  Clear the modification flag associated with the field at
   --  position Field.
   --  ------------------------------
   procedure Clear_Modified (Ref   : in out Object_Record'Class;
                             Field : in Positive) is
   begin
      Ref.Modified (Field) := False;
   end Clear_Modified;

end ADO.Objects;

Add comment

Add comment


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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

end Gen.Artifacts.XMI.Tests;

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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.PK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.FK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.DataModel", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "AWA.Bean", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

end Gen.Artifacts.XMI.Tests;

Check new stereotypes necessary for the code gneration


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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.PK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.FK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.DataModel", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "AWA.Bean", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

end Gen.Artifacts.XMI.Tests;

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

with Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Tag_Definition'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.PK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.FK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.DataModel", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "AWA.Bean", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

   --  Test searching an XMI Tag definition element by using its name.
   procedure Test_Find_Tag_Definition (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Tag_Definition is
        new Gen.Model.XMI.Find_Element (Element_Type        => Tag_Definition_Element,
                                        Element_Type_Access => Tag_Definition_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         Tag : Tag_Definition_Element_Access;
      begin
         Tag := Find_Tag_Definition (A.Nodes, "Dynamo.xmi", "ADO.Table.@dynamo.table.hasList",
                                     Gen.Model.XMI.BY_NAME);
         T.Assert (Tag /= null, "Tag definition not found");
      end;
   end Test_Find_Tag_Definition;

end Gen.Artifacts.XMI.Tests;

Implement the new unit test for tag definition


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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
package body Security.Policies.Tests is

   use Util.Tests;

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

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

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
      Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
--        end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
package body Security.Policies.Tests is

   use Util.Tests;

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

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

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
--        Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
--        end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

Fix compilation

Fix compilation


-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 2015, 2016, 2018, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;
private with Wiki.Buffers;
private with Util.Stacks;
private with Wiki.Nodes;
private with Wiki.Html_Parser;

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MARKDOWN);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_Table            : Boolean := False;
      In_Html             : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P    : in out Parser;
                         Trim : in Trim_End := None);

   procedure Flush_Block (Parser : in out Parser_Type);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar;
                       Number : in Natural);
   procedure Pop_List (P      : in out Parser);

   function Get_Current_Level (Parser : in Parser_Type) return Natural;

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 2015, 2016, 2018, 2020, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Documents;
with Wiki.Streams;
private with Wiki.Buffers;
private with Util.Stacks;
private with Wiki.Nodes;
private with Wiki.Html_Parser;

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MARKDOWN);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
      Quote_Level : Natural := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_Table            : Boolean := False;
      In_Html             : Boolean := False;
      In_Blockquote       : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P    : in out Parser;
                         Trim : in Trim_End := None);

   procedure Flush_Block (Parser : in out Parser_Type);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar;
                       Number : in Natural);
   procedure Pop_List (P      : in out Parser);

   function Get_Current_Level (Parser : in Parser_Type) return Natural;

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

Add Quote_Level in the stack block

Add Quote_Level in the stack block


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

--  == Input and Output streams ==
--  The <tt>Wiki.Streams</tt> package defines the interfaces used by
--  the parser or renderer to read and write their outputs.
--
--  The <tt>Input_Stream</tt> interface defines the interface that must be implemented to
--  read the source Wiki content.  The <tt>Read</tt> procedure is called by the parser
--  repeatedly while scanning the Wiki content.
--
--  The <tt>Output_Stream</tt> interface is the interface used by the renderer
--  to write their outpus.  It defines the <tt>Write</tt> procedure to write
--  a single character or a string.
--
--  @include wiki-streams-html.ads
--  @include wiki-streams-builders.ads
--  @include wiki-streams-html-builders.ads
package Wiki.Streams is

   pragma Preelaborate;

   type Input_Stream is limited interface;
   type Input_Stream_Access is access all Input_Stream'Class;

   --  Read one character from the input stream and return False to the <tt>Eof</tt> indicator.
   --  When there is no character to read, return True in the <tt>Eof</tt> indicator.
   procedure Read (Input : in out Input_Stream;
                   Char  : out Wiki.Strings.WChar;
                   Eof   : out Boolean) is abstract;

   type Output_Stream is limited interface;
   type Output_Stream_Access is access all Output_Stream'Class;

   --  Write the string to the output stream.
   procedure Write (Stream  : in out Output_Stream;
                    Content : in Wiki.Strings.WString) is abstract;

   --  Write a single character to the output stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Wiki.Strings.WChar) is abstract;

end Wiki.Streams;

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

--  == Input and Output streams ==
--  The <tt>Wiki.Streams</tt> package defines the interfaces used by
--  the parser or renderer to read and write their outputs.
--
--  The <tt>Input_Stream</tt> interface defines the interface that must be implemented to
--  read the source Wiki content.  The <tt>Read</tt> procedure is called by the parser
--  repeatedly while scanning the Wiki content.
--
--  The <tt>Output_Stream</tt> interface is the interface used by the renderer
--  to write their outpus.  It defines the <tt>Write</tt> procedure to write
--  a single character or a string.
--
--  @include wiki-streams-html.ads
--  @include wiki-streams-builders.ads
--  @include wiki-streams-html-builders.ads
--  @include wiki-streams-text_io.ads
--  @include wiki-streams-html-text_io.ads
package Wiki.Streams is

   pragma Preelaborate;

   type Input_Stream is limited interface;
   type Input_Stream_Access is access all Input_Stream'Class;

   --  Read one character from the input stream and return False to the <tt>Eof</tt> indicator.
   --  When there is no character to read, return True in the <tt>Eof</tt> indicator.
   procedure Read (Input : in out Input_Stream;
                   Char  : out Wiki.Strings.WChar;
                   Eof   : out Boolean) is abstract;

   type Output_Stream is limited interface;
   type Output_Stream_Access is access all Output_Stream'Class;

   --  Write the string to the output stream.
   procedure Write (Stream  : in out Output_Stream;
                    Content : in Wiki.Strings.WString) is abstract;

   --  Write a single character to the output stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Wiki.Strings.WChar) is abstract;

end Wiki.Streams;

Update the documentation

Update the documentation