-----------------------------------------------------------------------
--  Util.Beans.Objects.Maps -- Object maps
--  Copyright (C) 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 Ada.Strings.Unbounded;
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
package Util.Beans.Objects.Maps is new
Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                            Element_Type    => Object,
                            Hash            => Ada.Strings.Unbounded.Hash,
                            Equivalent_Keys => "=");

Integrate the EL.Objects, EL.Beans framework from Ada EL (See http://code.google.com/p/ada-el/) - Integrate the object map


-----------------------------------------------------------------------
--  Util.Concurrent.Arrays -- Concurrent Arrays
--  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.Finalization;
with Util.Concurrent.Counters;

--  The Util.Concurrent.Vectors generic package defines a vector which provides a
--  concurrent read only access and a protected exclusive write access.  This implementation
--  is intended to be used in applications that have to frequently iterate over the vector
--  content.  Adding or removing elements in the vector is assumed to be a not so frequent
--  operation.  Based on these assumptions, updating the vector array is implemented by
--  using the <tt>copy on write</tt> design pattern.  Read access is provided through a
--  reference object that can be shared by multiple readers.
--
--  The vector instance is declared and elements are added as follows:
--
--     C : Vector;
--
--     C.Append (E1);
--
--  To read and iterate over the vector, a task will get a reference to the vector array
--  and it will iterate over it.  The reference will be held until the reference object is
--  finalized.  While doing so, if another task updates the vector, a new vector array will
--  be associated with the vector instance (but this will not change the reader's references).
--
--     R : Ref := C.Get;
--
--     R.Iterate (Process'Access);
--     ...
--     R.Iterate (Process'Access);
--
--  In the above example, the two Iterate operations will iterate over the same list of
--  elements, even if another task appends an element in the middle.
--
--  Notes:
--  o This package is close to the Java class <tt>java.util.concurrent.CopyOnWriteArrayList</tt>.
--  o The package implements voluntarily a very small subset of Ada.Containers.Vectors.
--  o The implementation does not use the Ada container for performance and size reasons.
--  o The Iterate and Reverse_Iterate operation give a direct access to the element
generic
--     type Index_Type is range <>;
   type Element_Type is private;

   with function "=" (Left, Right : in Element_Type) return Boolean is <>;
package Util.Concurrent.Arrays is

   --  The reference to the read-only vector elements.
   type Ref is tagged private;

   --  Returns True if the container is empty.
   function Is_Empty (Container : in Ref) return Boolean;

   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type));

   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type));

   --  Vector of elements.
   type Vector is new Ada.Finalization.Limited_Controlled with private;

   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   function Get (Container : in Vector'Class) return Ref;

   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type);

   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type);

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector);

private

   --  To store the vector elements, we use an array which is allocated dynamically.
   --  The generated code is smaller compared to the use of Ada vectors container.
   type Element_Array is array (Positive range <>) of Element_Type;
   type Element_Array_Access is access all Element_Array;

   Null_Element_Array : constant Element_Array_Access := null;

   type Vector_Record (Len : Positive) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      List        : Element_Array (1 .. Len);
   end record;
   type Vector_Record_Access is access all Vector_Record;

   type Ref is new Ada.Finalization.Controlled with record
      Target : Vector_Record_Access := null;
   end record;

   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   overriding
   procedure Finalize (Obj : in out Ref);

   --  Update the reference counter after an assignment.
   overriding
   procedure Adjust (Obj : in out Ref);

   --  Vector of objects
   protected type Protected_Vector is

      --  Get a readonly reference to the vector.
      function Get return Ref;

      --  Append the element to the vector.
      procedure Append (Item : in Element_Type);

      --  Remove the element from the vector.
      procedure Remove (Item : in Element_Type);

   private
      Elements : Ref;
--        Elements      : Vector_Record_Access := null;
   end Protected_Vector;

   type Vector is new Ada.Finalization.Limited_Controlled with record
      List : Protected_Vector;
   end record;

end Util.Concurrent.Arrays;

-----------------------------------------------------------------------
--  Util.Concurrent.Arrays -- Concurrent Arrays
--  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.Finalization;
with Util.Concurrent.Counters;

--  == Introduction ==
--  The Util.Concurrent.Arrays generic package defines an array which provides a
--  concurrent read only access and a protected exclusive write access.  This implementation
--  is intended to be used in applications that have to frequently iterate over the array
--  content.  Adding or removing elements in the array is assumed to be a not so frequent
--  operation.  Based on these assumptions, updating the array is implemented by
--  using the <tt>copy on write</tt> design pattern.  Read access is provided through a
--  reference object that can be shared by multiple readers.
--
--  == Declaration ==
--  The package must be instantiated using the element type representing the array element.
--
--    package My_Array is new Util.Concurrent.Arrays (Element_Type => Integer);
--
--  == Adding Elements ==
--  The vector instance is declared and elements are added as follows:
--
--     C : My_Array.Vector;
--
--     C.Append (E1);
--
--  == Iterating over the array ==
--  To read and iterate over the vector, a task will get a reference to the vector array
--  and it will iterate over it.  The reference will be held until the reference object is
--  finalized.  While doing so, if another task updates the vector, a new vector array will
--  be associated with the vector instance (but this will not change the reader's references).
--
--     R : My_Array.Ref := C.Get;
--
--     R.Iterate (Process'Access);
--     ...
--     R.Iterate (Process'Access);
--
--  In the above example, the two `Iterate` operations will iterate over the same list of
--  elements, even if another task appends an element in the middle.
--
--  Notes:
--    * This package is close to the Java class `java.util.concurrent.CopyOnWriteArrayList`.
--    * The package implements voluntarily a very small subset of `Ada.Containers.Vectors`.
--    * The implementation does not use the Ada container for performance and size reasons.
--    * The `Iterate` and `Reverse_Iterate` operation give a direct access to the element.
generic
   type Element_Type is private;

   with function "=" (Left, Right : in Element_Type) return Boolean is <>;
package Util.Concurrent.Arrays is

   --  The reference to the read-only vector elements.
   type Ref is tagged private;

   --  Returns True if the container is empty.
   function Is_Empty (Container : in Ref) return Boolean;

   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type));

   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type));

   --  Vector of elements.
   type Vector is new Ada.Finalization.Limited_Controlled with private;

   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   function Get (Container : in Vector'Class) return Ref;

   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type);

   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type);

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector);

private

   --  To store the vector elements, we use an array which is allocated dynamically.
   --  The generated code is smaller compared to the use of Ada vectors container.
   type Element_Array is array (Positive range <>) of Element_Type;
   type Element_Array_Access is access all Element_Array;

   Null_Element_Array : constant Element_Array_Access := null;

   type Vector_Record (Len : Positive) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      List        : Element_Array (1 .. Len);
   end record;
   type Vector_Record_Access is access all Vector_Record;

   type Ref is new Ada.Finalization.Controlled with record
      Target : Vector_Record_Access := null;
   end record;

   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   overriding
   procedure Finalize (Obj : in out Ref);

   --  Update the reference counter after an assignment.
   overriding
   procedure Adjust (Obj : in out Ref);

   --  Vector of objects
   protected type Protected_Vector is

      --  Get a readonly reference to the vector.
      function Get return Ref;

      --  Append the element to the vector.
      procedure Append (Item : in Element_Type);

      --  Remove the element from the vector.
      procedure Remove (Item : in Element_Type);

   private
      Elements : Ref;
   end Protected_Vector;

   type Vector is new Ada.Finalization.Limited_Controlled with record
      List : Protected_Vector;
   end record;

end Util.Concurrent.Arrays;

Update the documentation to be extracted by dynamo


-----------------------------------------------------------------------
--  util-log-appenders-rolling_files -- Rolling file log appenders
--  Copyright (C) 2001 - 2021 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.Finalization;
with Ada.Directories;
with Util.Properties.Basic;
with Util.Log.Appenders.Formatter;
package body Util.Log.Appenders.Rolling_Files is

   use Ada;
   use Ada.Finalization;

   package Bool_Prop renames Util.Properties.Basic.Boolean_Property;
   package Int_Prop renames Util.Properties.Basic.Integer_Property;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out File_Entity) is
   begin
      Text_IO.Close (File => Object.Output);
   end Finalize;

   protected body Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager) is
         function Get_Policy return Util.Files.Rolling.Policy_Type with Inline;
         function Get_Strategy return Util.Files.Rolling.Strategy_Type with Inline;

         File  : constant String := Properties.Get (Base & ".fileName", Name & ".log");
         Pat   : constant String := Properties.Get (Base & ".filePattern", Base & "-%i.log");

         function Get_Policy return Util.Files.Rolling.Policy_Type is
            Str   : constant String := Properties.Get (Base & ".policy", "time");
            Inter : constant Integer := Int_Prop.Get (Properties, Base & ".policyInterval", 1);
            Size  : constant String := Properties.Get (Base & ".minSize", "1000000");
         begin
            if Str = "none" then
               return (Kind => Util.Files.Rolling.No_Policy);
            elsif Str = "time" then
               return (Kind     => Util.Files.Rolling.Time_Policy,
                       Interval => Inter);
            else
               return (Kind => Util.Files.Rolling.Size_Policy,
                       Size => Ada.Directories.File_Size'Value (Size));
            end if;

         exception
            when others =>
               return (Kind => Util.Files.Rolling.No_Policy);
         end Get_Policy;

         function Get_Strategy return Util.Files.Rolling.Strategy_Type is
            Str   : constant String := Properties.Get (Base & ".strategy", "ascending");
            Min   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMin", 0);
            Max   : constant Integer := Int_Prop.Get (Properties, Base & ".policyMax", 0);
         begin
            if Str = "direct" then
               return (Kind => Util.Files.Rolling.Direct_Strategy,
                       Max_Files => Max);

            elsif Str = "descending" then
               return (Kind      => Util.Files.Rolling.Descending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            else
               return (Kind      => Util.Files.Rolling.Ascending_Strategy,
                       Min_Index => Min,
                       Max_Index => Max);

            end if;
         end Get_Strategy;
      begin
         Append := Bool_Prop.Get (Properties, Base & ".append", True);
         Manager.Initialize (Path     => File,
                             Pattern  => Pat,
                             Policy   => Get_Policy,
                             Strategy => Get_Strategy);
      end Initialize;

      procedure Openlog (File : out File_Refs.Ref) is
      begin
         if not Manager.Is_Rollover_Necessary then
            File := Current;
            return;
         end if;

         Closelog;
         Current := File_Refs.Create;

         Manager.Rollover;

         declare
            Path : constant String := Manager.Get_Current_Path;
            Dir  : constant String := Ada.Directories.Containing_Directory (Path);
         begin
            if not Ada.Directories.Exists (Dir) then
               Ada.Directories.Create_Path (Dir);
            end if;

            if not Ada.Directories.Exists (Path) then
               Text_IO.Create (File => Current.Value.Output,
                               Name => Path);
            else
               Text_IO.Open (File => Current.Value.Output,
                             Name => Path,
                             Mode => (if Append then Text_IO.Append_File
                                      else Text_IO.Out_File));
            end if;
         end;
      end Openlog;

      procedure Flush (File : out File_Refs.Ref) is
      begin
         if not Current.Is_Null then
            File := Current;
         end if;
      end Flush;

      procedure Closelog is
         Empty : File_Refs.Ref;
      begin
         --  Close the current log by releasing its reference counter.
         Current := Empty;
      end Closelog;

   end Rolling_File;

   overriding
   procedure Append (Self    : in out File_Appender;
                     Message : in Util.Strings.Builders.Builder;
                     Date    : in Ada.Calendar.Time;
                     Level   : in Level_Type;
                     Logger  : in String) is

   begin
      if Self.Level >= Level then
         declare
            File : File_Refs.Ref;

            procedure Write_File (Data : in String) with Inline_Always;

            procedure Write_File (Data : in String) is
            begin
               Text_IO.Put (File.Value.Output, Data);
            end Write_File;

            procedure Write is new Formatter (Write_File);
         begin
            Self.File.Openlog (File);
            if not File.Is_Null then
               Write (Self, Message, Date, Level, Logger);
               Text_IO.New_Line (File.Value.Output);
               if Self.Immediate_Flush then
                  Text_IO.Flush (File.Value.Output);
               end if;
            end if;
         end;
      end if;
   end Append;

   --  ------------------------------
   --  Flush the log events.
   --  ------------------------------
   overriding
   procedure Flush (Self   : in out File_Appender) is
      File : File_Refs.Ref;
   begin
      Self.File.Flush (File);
      if not File.Is_Null then
         Text_IO.Flush (File.Value.Output);
      end if;
   end Flush;

   --  ------------------------------
   --  Flush and close the file.
   --  ------------------------------
   overriding
   procedure Finalize (Self : in out File_Appender) is
   begin
      Self.File.Closelog;
   end Finalize;

   --  ------------------------------
   --  Create a file appender and configure it according to the properties
   --  ------------------------------
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
                   return Appender_Access is
      Base    : constant String := "appender." & Name;
      Result  : constant File_Appender_Access
        := new File_Appender '(Limited_Controlled with Length => Name'Length,
                               Name => Name,
                               others => <>);
   begin
      Result.Set_Level (Name, Properties, Default);
      Result.Set_Layout (Name, Properties, FULL);
      Result.Immediate_Flush := Bool_Prop.Get (Properties, Base & ".immediateFlush", True);
      Result.File.Initialize (Name, Base, Properties);
      return Result.all'Access;
   end Create;

end Util.Log.Appenders.Rolling_Files;

Add support for rolling file appender

Add support for rolling file appender


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

with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   function Get_Test_Library return String;
   function Get_Test_Symbol return String;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "libz.dll";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "inflate";
      else
         return "compress";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.DLLs.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

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

with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   function Get_Test_Library return String;
   function Get_Test_Symbol return String;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "libz.dll";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "EVP_sha";
      else
         return "compress";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.DLLs.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

Change the symbol name to use a symbol that hopefully exists in almost all installation of libcrypto on Unix


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

with Util.Tests;

package Util.Events.Timers.Tests is

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

   type Test is new Util.Tests.Test
     and Util.Events.Timers.Timer with record
      Count : Natural := 0;
   end record;

   overriding
   procedure Time_Handler (Sub   : in out Test;
                           Event : in out Timer_Ref'Class);

   procedure Test_Timer_Event (T : in out Test);

end Util.Events.Timers.Tests;

Add new unit tests for the timer management package


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . L I S T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

separate (Lib)
procedure List (File_Names_Only : Boolean := False) is

   Num_Units : constant Nat := Int (Units.Last) - Int (Units.First) + 1;
   --  Number of units in file table

   Sorted_Units : Unit_Ref_Table (1 .. Num_Units);
   --  Table of unit numbers that we will sort

   Unit_Hed : constant String := "Unit name                        ";
   Unit_Und : constant String := "---------                        ";
   Unit_Bln : constant String := "                                 ";
   File_Hed : constant String := "File name                     ";
   File_Und : constant String := "---------                     ";
   File_Bln : constant String := "                              ";
   Time_Hed : constant String := "Time stamp";
   Time_Und : constant String := "----------";

   Unit_Length : constant Natural := Unit_Hed'Length;
   File_Length : constant Natural := File_Hed'Length;

begin
   --  First step is to make a sorted table of units

   for J in 1 .. Num_Units loop
      Sorted_Units (J) := Unit_Number_Type (Int (Units.First) + J - 1);
   end loop;

   Sort (Sorted_Units);

   --  Now we can generate the unit table listing

   Write_Eol;

   if not File_Names_Only then
      Write_Str (Unit_Hed);
      Write_Str (File_Hed);
      Write_Str (Time_Hed);
      Write_Eol;

      Write_Str (Unit_Und);
      Write_Str (File_Und);
      Write_Str (Time_Und);
      Write_Eol;
      Write_Eol;
   end if;

   for R in Sorted_Units'Range loop
      if File_Names_Only then
         if not Is_Internal_File_Name
                  (File_Name (Source_Index (Sorted_Units (R))))
         then
            Write_Name (Full_File_Name (Source_Index (Sorted_Units (R))));
            Write_Eol;
         end if;

      else
         Write_Unit_Name (Unit_Name (Sorted_Units (R)));

         if Name_Len > (Unit_Length - 1) then
            Write_Eol;
            Write_Str (Unit_Bln);
         else
            for J in Name_Len + 1 .. Unit_Length loop
               Write_Char (' ');
            end loop;
         end if;

         Write_Name (Full_File_Name (Source_Index (Sorted_Units (R))));

         if Name_Len > (File_Length - 1) then
            Write_Eol;
            Write_Str (Unit_Bln);
            Write_Str (File_Bln);
         else
            for J in Name_Len + 1 .. File_Length loop
               Write_Char (' ');
            end loop;
         end if;

         Write_Str (String (Time_Stamp (Source_Index (Sorted_Units (R)))));
         Write_Eol;
      end if;
   end loop;

   Write_Eol;
end List;

Add GNAT files for ASIS

Add GNAT files for ASIS


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  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.
-----------------------------------------------------------------------

--  == OpenID ==
--  The Security.OpenID package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The OpenID manager must be declared and configured.
--
--    Mgr   : Security.OpenID.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the OpenID realm and set the OpenID return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify");
--
--  After this initialization, the OpenID manager can be used in the authentication process.
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.OpenID.End_Point;
--    Assoc    : constant Security.OpenID.Association_Access := new Security.OpenID.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc   : Association_Access := ...;  --  Get the association saved in the session.
--    Auth    : OpenID.Authentication;
--    Params  : Auth_Params;
--
--  The OpenID manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Security.OpenID.Get_Status (Auth) = Security.OpenID.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.OpenID.Principal_Access := Security.OpenID.Create_Principal (Auth);
--
private package Security.Auth.OpenID is

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is new Security.Auth.Manager with private;

   --  Initialize the authentication realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   type Manager is new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
   end record;

end Security.Auth.OpenID;

Refactor the OpenID authentication to be based on the generic authentication framework


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . V C H E C K                            --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public License  distributed with ASIS-for-GNAT; see   file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;

with GNAT.OS_Lib;             use GNAT.OS_Lib;

with Asis.Compilation_Units;  use Asis.Compilation_Units;
with Asis.Elements;           use Asis.Elements;
with Asis.Exceptions;         use Asis.Exceptions;
with Asis.Implementation;     use Asis.Implementation;

with Asis.Set_Get;            use Asis.Set_Get;
with Asis.Text.Set_Get;       use Asis.Text.Set_Get;

with A4G.A_Debug;             use A4G.A_Debug;
with A4G.A_Opt;               use A4G.A_Opt;
with A4G.A_Output;            use A4G.A_Output;

with Fname;                   use Fname;
with Gnatvsn;                 use Gnatvsn;
with Lib;                     use Lib;
with Namet;                   use Namet;
with Output;                  use Output;
with Sinput;                  use Sinput;
with Types;                   use Types;

package body A4G.Vcheck is

   ----------------
   -- Local Data --
   ----------------

   Recursion_Count : Natural := 0;
   --  Used in Report_ASIS_Bug to prevent too many runaway recursion steps to
   --  be done if something bad happens while reporting an ASIS bug. The
   --  problem is that ASIS queries are used to form the diagnostic message,
   --  and some circularities are possible here.

   Max_Recursions_Allowed : constant Positive := 1;
   --  This constant limits the number of recursion calls of Report_ASIS_Bug.
   --  When this limit is achieved, we try once again, but with turning OFF
   --  including the text position into Element's debug image. If this last
   --  step also results in resursive call to Report_ASIS_Bug, we
   --  unconditionally do OS_Abort.
   --
   --  Until we finish the revising of all the exception handlers in the
   --  ASIS implementation code, we limit the recursion depth by one, because
   --  some circularities are possible in the routines that are not "terminal"
   --  ASIS queries but which make use of ASIS queries and contain exception
   --  handlers forming or modifying diagnostic info.

   LT : String renames A4G.A_Types.ASIS_Line_Terminator;

   Current_Pos : Natural range 0 .. Diagnosis_String_Length;
   --  The pointer to the last filled position in the logical text line
   --  in the Diagnosis buffer

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Add_Str (Str : String);
   --  This procedure is similar to Add, but it tries to keep the lengths
   --  of strings stores in Diagnosis_Buffer under 76 characters. Str should
   --  not contain any character(s) caused line breaks. If (a part of) the
   --  argument can be added to the current Diagnosis string and if this string
   --  already contains some text, (a part of) the argument is separated by a
   --  space character.

   procedure Close_Str;
   --  Closes a current string in the Diagnosis buffer

   procedure Reset_Diagnosis_Buffer;
   --  Resets the Diagnosis buffer

   --  ??? The diagnosis buffer needs a proper documentation!!!!

   procedure Set_Error_Status_Internal
     (Status    : Error_Kinds      := Not_An_Error;
      Diagnosis : String := Nil_Asis_String;
      Query     : String := Nil_Asis_String);
   --  This procedure allows to avoid dynamicaly allocated strings in calls
   --  to Set_Error_Status in Check_Validity. Check_Validity is called in
   --  all ASIS structural and semantic queries, so a dynamic string as an
   --  argument of internal call results in significant performance penalties.
   --  (See E705-008).

   ---------
   -- Add --
   ---------
   procedure Add (Phrase : String) is
   begin
      if Diagnosis_Len = Max_Diagnosis_Length then
         return;
      end if;
      for I in Phrase'Range loop
         Diagnosis_Len := Diagnosis_Len + 1;
         Diagnosis_Buffer (Diagnosis_Len) := Phrase (I);
         if Diagnosis_Len = Max_Diagnosis_Length then
            exit;
         end if;
      end loop;
   end Add;

   -------------
   -- Add_Str --
   -------------

   procedure Add_Str (Str : String) is

      First_Idx : Natural := Str'First;
      Last_Idx  : Natural := First_Idx;
      --  Indexes of the first and last subwords in Str

      Word_Len  : Positive;
      Available : Positive;

      Str_Last : constant Positive := Str'Last;
   begin

      while Last_Idx < Str_Last loop

         Last_Idx := Str_Last;

         for J in First_Idx .. Str_Last loop

            if Str (J) = ' ' then
               Last_Idx := J - 1;
               exit;
            end if;

         end loop;

         Word_Len := Last_Idx - First_Idx;

         if Current_Pos = 0 then
            Available := Diagnosis_String_Length;
         else
            Available := Diagnosis_String_Length - (Current_Pos + 1);
         end if;

         if Word_Len <= Available then

            if Current_Pos > 0 then
               Add (" ");
               Current_Pos := Current_Pos + 1;
            end if;

            Add (Str (First_Idx .. Last_Idx));

            Current_Pos := Current_Pos + Word_Len;

         else

            Add (ASIS_Line_Terminator);
            Add (Str (First_Idx .. Last_Idx));
            Current_Pos := Word_Len;
         end if;

         if Current_Pos >=
            Diagnosis_String_Length - ASIS_Line_Terminator'Length
         then
            Add (ASIS_Line_Terminator);
            Current_Pos := 0;
         end if;

         First_Idx := Last_Idx + 2;

      end loop;

   end Add_Str;

   ----------------------
   --   Check_Validity --
   ----------------------

   procedure Check_Validity
     (Compilation_Unit : Asis.Compilation_Unit;
      Query            : String) is
   begin

      if Not_Nil (Compilation_Unit) and then
         not Valid (Compilation_Unit)
      then

         Set_Error_Status_Internal
           (Status    => Value_Error,
            Diagnosis => "Invalid Unit value in ",
            Query     => Query);

         raise ASIS_Inappropriate_Compilation_Unit;
      end if;

   end Check_Validity;

   procedure Check_Validity (Element : Asis.Element;
                             Query   : String) is
   begin

      if Kind (Element) /= Not_An_Element and then
         not Valid (Element)
      then
         Set_Error_Status_Internal
           (Status    => Value_Error,
            Diagnosis => "Invalid Element value in ",
            Query     => Query);

         raise ASIS_Inappropriate_Element;

      end if;

   end Check_Validity;

   procedure Check_Validity
     (Line  : Asis.Text.Line;
      Query : String)
   is
   begin
      if not Asis.Text.Is_Nil (Line) and then not Valid (Line) then
         Set_Error_Status_Internal
           (Status    => Value_Error,
            Diagnosis => "Invalid Line value in ",
            Query     =>  Query);

         raise ASIS_Inappropriate_Line;
      end if;
   end Check_Validity;

   procedure Check_Validity (Context : Asis.Context;
                             Query   : String) is
   begin
      if not Valid (Context) then
         Set_Error_Status_Internal
           (Status    => Value_Error,
            Diagnosis => "Unopened Context argument in ",
            Query     => Query);

         raise ASIS_Inappropriate_Context;

      end if;

   end Check_Validity;

   ---------------
   -- Close_Str --
   ---------------

   procedure Close_Str is
   begin
      Add (ASIS_Line_Terminator);
      Current_Pos := 0;
   end Close_Str;

   ---------------------
   -- Report_ASIS_Bug --
   ---------------------

   procedure Report_ASIS_Bug
     (Query_Name    : String;
      Ex            : Exception_Occurrence;
      Arg_Element   : Asis.Element          := Nil_Element;
      Arg_Element_2 : Asis.Element          := Nil_Element;
      Arg_CU        : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_CU_2      : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_Line      : Asis.Text.Line        := Nil_Line;
      Arg_Span      : Asis.Text.Span        := Nil_Span;
      Bool_Par_ON   : Boolean               := False;
      Context_Par   : Boolean               := False
      --  What else???
      )
   is
      Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL;
      Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF;

      procedure Repeat_Char (Char : Character; Col : Nat; After : Character);
      --  This procedure is similar to Comperr.Repeat_Char, but it does nothing
      --  if Generate_Bug_Box is set OFF.
      --
      --  Output Char until current column is at or past Col, and then output
      --  the character given by After (if column is already past Col on entry,
      --  then the effect is simply to output the After character).

      procedure End_Line;
      --  This procedure is similar to Comperr.End_Line, but it does nothing
      --  if Generate_Bug_Box is set OFF.
      --
      --  Add blanks up to column 76, and then a final vertical bar

      procedure Write_Char (C : Character);
      procedure Write_Str  (S : String);
      procedure Write_Eol;
      --  These three subprograms are similar to the procedures with the same
      --  names from the GNAT Output package except that they do nothing in
      --  case if Generate_Bug_Box is set OFF.

      procedure End_Line is
      begin

         if Generate_Bug_Box then
            Repeat_Char (' ', 76, '|');
            Write_Eol;
         end if;

      end End_Line;

      procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
      begin

         if Generate_Bug_Box then
            while Column < Col loop
               Write_Char (Char);
            end loop;

            Write_Char (After);
         end if;

      end Repeat_Char;

      procedure Write_Char (C : Character) is
      begin

         if Generate_Bug_Box then
            Output.Write_Char (C);
         end if;

      end Write_Char;

      procedure Write_Str  (S : String) is
      begin

         if Generate_Bug_Box then
            Output.Write_Str (S);
         end if;

      end Write_Str;

      procedure Write_Eol is
      begin

         if Generate_Bug_Box then
            Output.Write_Eol;
         end if;

      end Write_Eol;

   begin

      if Recursion_Count >= Max_Recursions_Allowed then

         if Debug_Flag_I then
            --  We can not do anything reasonable any more:
            OS_Abort;
         else
            --  We will try the last time with turning off span computing
            --  as a part of debug output
            Debug_Flag_I := True;
            --  It is not safe to put this flag OFF (it it was set OFF before
            --  the call to Report_ASIS_Bug), because it may be some
            --  circularities (see the comment for Max_Recursions_Allowed
            --  global variable). We may want to revise this decision when
            --  the revision of all the exception handlers in the ASIS code
            --  is complete.
         end if;

      end if;

      Recursion_Count := Recursion_Count + 1;

      --  This procedure is called in case of an ASIS implementation bug, so
      --  we do not care very much about efficiency
      Set_Standard_Error;

      --  Generate header for bug box

      Write_Eol;
      Write_Char ('+');
      Repeat_Char ('=', 29, 'A');
      Write_Str ("SIS BUG DETECTED");
      Repeat_Char ('=', 76, '+');
      Write_Eol;

      --  Output ASIS version identification

      Write_Str ("| ");
      Write_Str (To_String (ASIS_Implementor_Version));

      --  Output the exception info:
      Write_Str (" ");
      Write_Str (Exception_Name (Ex));
      Write_Char (' ');
      Write_Str (Exception_Message (Ex));
      End_Line;

      --  Output the query name and call details
      Write_Str ("| when processing ");
      Write_Str (Query_Name);

      if Bool_Par_ON then
         Write_Str (" (Boolean par => ON)");
      elsif Context_Par then
         Write_Str (" (with Context parameter)");
      end if;

      End_Line;

      --  Add to ASIS Diagnosis:
      Reset_Diagnosis_Buffer;
      Add_Str ("ASIS internal implementation error detected for");
      Close_Str;
      Add_Str (Query_Name);

      if Bool_Par_ON then
         Add_Str ("(Boolean par => ON)");
      elsif Context_Par then
         Add_Str ("(with Context parameter)");
      end if;

      Close_Str;

      --  Add information about the argument of the call (bug box)
      if not Is_Nil (Arg_Element) or else
         not Is_Nil (Arg_CU)
      then

         Write_Str ("| ");
         Write_Str ("called with ");

         if not Is_Nil (Arg_Element) then
            Write_Str (Int_Kind (Arg_Element)'Img);
            Write_Str (" Element");
            End_Line;

         elsif not Is_Nil (Arg_CU) then
            Write_Str (Kind (Arg_CU)'Img);
            Write_Str (" Compilation Unit");
            End_Line;
         end if;

         Write_Str ("| (for full details see the debug image after the box)");
         End_Line;
      end if;

      --  Add information about the argument of the call (Diagnosis string)

      if not Is_Nil (Arg_Element) or else
         not Is_Nil (Arg_CU)
      then
         Add_Str ("called with");
         Close_Str;

         if not Is_Nil (Arg_Element) then
            Debug_String (Arg_Element, No_Abort => True);
            Add (Debug_Buffer (1 .. Debug_Buffer_Len));

         elsif not Is_Nil (Arg_CU) then
            Debug_String (Arg_CU, No_Abort => True);
            Add (Debug_Buffer (1 .. Debug_Buffer_Len));
         end if;

         Close_Str;

         --  Note, that if we do not generate the bug box, in case if the query
         --  have two Element or CU parameters, the information about the
         --  second parameter is missed in the ASIS Diagnosis
      end if;

      Add_Str (Exception_Name (Ex));
      Add     (" ");
      Add_Str (Exception_Message (Ex));

      if not Generate_Bug_Box then
         Close_Str;
         Add_Str ("For more details activate the ASIS bug box");
      end if;

      --  Completing the bug box

      if Is_FSF_Version then
         Write_Str
           ("| Please submit a bug report; see" &
            " http://gcc.gnu.org/bugs.html.");
         End_Line;

      elsif Is_GPL_Version then

         Write_Str
           ("| Please submit a bug report by email " &
            "to report@adacore.com.");
         End_Line;

         Write_Str
           ("| GAP members can alternatively use GNAT Tracker:");
         End_Line;

         Write_Str
           ("| http://www.adacore.com/ " &
            "section 'send a report'.");
         End_Line;

         Write_Str
           ("| See gnatinfo.txt for full info on procedure " &
            "for submitting bugs.");
         End_Line;

      else
         Write_Str
           ("| Please submit a bug report using GNAT Tracker:");
         End_Line;

         Write_Str
           ("| http://www.adacore.com/gnattracker/ " &
            "section 'send a report'.");
         End_Line;

         Write_Str
           ("| alternatively submit a bug report by email " &
            "to report@adacore.com,");
         End_Line;

         Write_Str
           ("| including your customer number #nnn " &
            "in the subject line.");
         End_Line;
      end if;

      Write_Str
        ("| Use a subject line meaningful to you and us to track the bug.");
      End_Line;

      Write_Str
        ("| Include the entire contents of this bug " &
         "box and the ASIS debug info");
      End_Line;

      Write_Str ("| in the report.");
      End_Line;

      Write_Str
        ("| Include the exact list of the parameters of the ASIS queries ");
      End_Line;

      Write_Str
        ("| Asis.Implementation.Initialize and " &
         "Asis.Ada_Environments.Associate");
      End_Line;

      Write_Str
        ("| from the ASIS application for which the bug is detected");
      End_Line;

      Write_Str
        ("| Also include sources listed below in gnatchop format");
      End_Line;

      Write_Str
        ("| (concatenated together with no headers between files).");
      End_Line;

      if not Is_FSF_Version then
         Write_Str ("| Use plain ASCII or MIME attachment.");
         End_Line;
      end if;

      Write_Str
        ("| NOTE: ASIS bugs may be submitted to asis-report@adacore.com");
      End_Line;

      --  Complete output of bug box

      Write_Char ('+');
      Repeat_Char ('=', 76, '+');
      Write_Eol;
      Write_Eol;

      --  Argument debug image(s)

      if not Is_Nil (Arg_Element) or else
         not Is_Nil (Arg_CU)      or else
         not Is_Nil (Arg_Line)
      then
         Write_Str ("The debug image(s) of the argument(s) of the call");
         Write_Eol;

         if not (Is_Nil (Arg_Element_2) and then Is_Nil (Arg_CU_2)) then
            Write_Str ("***First argument***");
            Write_Eol;
         end if;

         Write_Str (Debug_Buffer (1 .. Debug_Buffer_Len));
         Write_Eol;
         Write_Eol;

         if not Is_Nil (Arg_Element_2) then
            Debug_String (Arg_Element_2, No_Abort => True);
         elsif not Is_Nil (Arg_CU_2) then
            Debug_String (Arg_CU_2, No_Abort => True);
         end if;

         if not (Is_Nil (Arg_Element_2) and then Is_Nil (Arg_CU_2)) then
            Write_Str ("***Second argument***");
            Write_Eol;
            Write_Str (Debug_Buffer (1 .. Debug_Buffer_Len));
            Write_Eol;
            Write_Eol;
         end if;

         if not Is_Nil (Arg_Line) then

            if not Is_Nil (Arg_Element) then
               Write_Str ("***Line argument***");
               Write_Eol;
            end if;

            if Recursion_Count >= Max_Recursions_Allowed and then
               Debug_Flag_I
            then
               --  There is a real possibility that we can not output the
               --  debug image of the argument line because of the bug being
               --  reported:
               Write_Str ("Line image can not be reported ");
               Write_Str ("because of the internal error");
               Write_Eol;
               Write_Eol;
            else
               Write_Str (To_String (Debug_Image (Arg_Line)));
               Write_Eol;
               Write_Eol;
            end if;

         end if;

         if not Is_Nil (Arg_Span) then

            if not Is_Nil (Arg_Element) then
               Write_Str ("***Span argument***");
               Write_Eol;
            end if;

            Write_Str ("First_Line   =>");
            Write_Str (Arg_Span.First_Line'Img);
            Write_Eol;

            Write_Str ("First_Column =>");
            Write_Str (Arg_Span.First_Column'Img);
            Write_Eol;

            Write_Str ("Last_Line    =>");
            Write_Str (Arg_Span.Last_Line'Img);
            Write_Eol;

            Write_Str ("Last_Column  =>");
            Write_Str (Arg_Span.Last_Column'Img);
            Write_Eol;
            Write_Eol;

         end if;

      end if;

      Write_Str ("Please include these source files with error report");
      Write_Eol;
      Write_Str ("Note that list may not be accurate in some cases, ");
      Write_Eol;
      Write_Str ("so please double check that the problem can still ");
      Write_Eol;
      Write_Str ("be reproduced with the set of files listed.");
      Write_Eol;
      Write_Eol;

      if Generate_Bug_Box then

         for U in Main_Unit .. Last_Unit loop
            begin
               if not Is_Internal_File_Name
                        (File_Name (Source_Index (U)))
               then
                  Write_Name (Full_File_Name (Source_Index (U)));
                  Write_Eol;
               end if;

            --  No point in double bug box if we blow up trying to print
            --  the list of file names! Output informative msg and quit.

            exception
               when others =>
                  Write_Str ("list may be incomplete");
                  exit;
            end;
         end loop;

      end if;

      Write_Eol;

      Set_Standard_Output;

      if Keep_Going then
         --  Raise ASIS_Failed and go ahead (the Diagnosis is already formed)
         Status_Indicator := Unhandled_Exception_Error;
         Recursion_Count  := Recursion_Count - 1;
         raise ASIS_Failed;
      else
         OS_Exit (1);
      end if;

   exception
      when ASIS_Failed =>
         raise;

      when  Internal_Ex : others =>

         Write_Eol;
         Write_Str ("The diagnostis can not be completed because of " &
                    "the following error:");
         Write_Eol;
         Write_Str (Exception_Name (Ex));
         Write_Char (' ');
         Write_Str (Exception_Message (Ex));
         Write_Eol;

         Close_Str;
         Add_Str ("The diagnostis can not be completed because of " &
                  "the following error:");
         Close_Str;

         Add_Str (Exception_Name (Ex));
         Add     (" ");
         Add_Str (Exception_Message (Ex));

         Add_Str (Exception_Information (Internal_Ex));

         Set_Standard_Output;

         if Keep_Going then
            Status_Indicator := Unhandled_Exception_Error;
            --  Debug_Flag_I     := Skip_Span_In_Debug_Image;
            raise ASIS_Failed;
         else
            OS_Exit (1);
         end if;

   end Report_ASIS_Bug;

   ----------------------------
   -- Reset_Diagnosis_Buffer --
   ----------------------------

   procedure Reset_Diagnosis_Buffer is
   begin
      Diagnosis_Len := 0;
      Current_Pos   := 0;
   end Reset_Diagnosis_Buffer;

   -----------------------------
   -- Raise_ASIS_Failed (new) --
   -----------------------------

   procedure Raise_ASIS_Failed
     (Diagnosis    : String;
      Argument     : Asis.Element            := Nil_Element;
      Stat         : Asis.Errors.Error_Kinds := Internal_Error;
      Bool_Par     : Boolean                 := False;
      Internal_Bug : Boolean                 := True)
   is
   begin
      Diagnosis_Len := 0;

      if Internal_Bug then
         Add ("Internal implementation error: ");
      end if;

      Add (Diagnosis);

      if Bool_Par then
         Add (LT & "(Boolean parameter is TRUE)");
      end if;

      if not Is_Nil (Argument) then
         Add (LT & "when processing ");
         Debug_String (Argument);
         Add (Debug_Buffer (1 .. Debug_Buffer_Len));
      end if;

      Status_Indicator := Stat;

      raise ASIS_Failed;

   end Raise_ASIS_Failed;

   -------------------------------------
   -- Raise_ASIS_Failed_In_Traversing --
   -------------------------------------

   procedure Raise_ASIS_Failed_In_Traversing
     (Start_Element  : Asis.Element;
      Failure_At     : Asis.Element;
      Pre_Op         : Boolean;
      Exception_Info : String)
   is
   begin
      Diagnosis_Len := 0;

      Add ("Traversal failure. Tarversal started at:" & LT);
      Debug_String (Start_Element);
      Add (Debug_Buffer (1 .. Debug_Buffer_Len) & LT);

      if Pre_Op then
         Add ("Pre-operation");
      else
         Add ("Post-operation");
      end if;

      Add (" failed at:" & LT);
      Debug_String (Failure_At);
      Add (Debug_Buffer (1 .. Debug_Buffer_Len));
      Add (LT & Exception_Info);

      Status_Indicator := Unhandled_Exception_Error;

      raise ASIS_Failed;

   end Raise_ASIS_Failed_In_Traversing;

---------------------------------------------------------------

   procedure Raise_ASIS_Inappropriate_Compilation_Unit
                         (Diagnosis : String) is
   begin

      Set_Error_Status (Status    => Value_Error,
                        Diagnosis => "Inappropriate Unit Kind in "
                                    & Diagnosis);

      raise ASIS_Inappropriate_Compilation_Unit;

   end Raise_ASIS_Inappropriate_Compilation_Unit;
----------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Element
     (Diagnosis  : String;
      Wrong_Kind : Internal_Element_Kinds;
      Status     : Error_Kinds      := Value_Error) is
   begin

      Set_Error_Status (Status    => Status,
                        Diagnosis => "Inappropriate Element Kind in " &
                                      Diagnosis                       &
                                     " (" & Wrong_Kind'Img & ")");

      raise ASIS_Inappropriate_Element;

   end Raise_ASIS_Inappropriate_Element;
----------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Line_Number
     (Diagnosis : String;
      Status    : Error_Kinds      := Value_Error) is
   begin
      Set_Error_Status (Status    => Status,
                        Diagnosis => "Inappropriate Lines/Span Kind in "
                                    & Diagnosis);
      raise ASIS_Inappropriate_Line_Number;
   end Raise_ASIS_Inappropriate_Line_Number;
----------------------------------------------------------------------
   procedure Not_Implemented_Yet (Diagnosis : String) is
   begin

      Set_Error_Status (Status    => Not_Implemented_Error,
                        Diagnosis => "Not Implemented Query:" & LT
                                    & Diagnosis);

      raise ASIS_Failed;

   end Not_Implemented_Yet;
--------------------------------------------------------------------
   procedure Set_Error_Status
     (Status    : Error_Kinds      := Not_An_Error;
      Diagnosis : String := Nil_Asis_String)
   is
   begin
      if Status     = Not_An_Error and then
         Diagnosis /= Nil_Asis_String
      then
         Status_Indicator := Internal_Error;
         Diagnosis_Len    := Incorrect_Setting_Len + ASIS_Line_Terminator_Len;
         Diagnosis_Buffer (1 .. Diagnosis_Len)
                          := Incorrect_Setting & ASIS_Line_Terminator;
         raise ASIS_Failed;
      end if;

      Status_Indicator := Status;

      Diagnosis_Len    := Diagnosis'Length;

      Diagnosis_Buffer (1 .. Diagnosis_Len) := Diagnosis;

   end Set_Error_Status;

   procedure Set_Error_Status_Internal
     (Status    : Error_Kinds      := Not_An_Error;
      Diagnosis : String := Nil_Asis_String;
      Query     : String := Nil_Asis_String)
   is
   begin
      Set_Error_Status
        (Status => Status,
         Diagnosis => Diagnosis & Query);
   end Set_Error_Status_Internal;

----------------------------------------------------------------------

   --------------------------
   -- Add_Call_Information --
   --------------------------

   procedure Add_Call_Information
     (Outer_Call : String;
      Argument   : Asis.Element := Nil_Element;
      Bool_Par   : Boolean := False)
   is
   begin
      Add (LT & "called in " & Outer_Call);

      if Bool_Par then
         Add (LT & "(Boolean parameter is TRUE)");
      end if;

      if not Is_Nil (Argument) then
         Add (LT & "with the argument : ");
         Debug_String (Argument);
         Add (Debug_Buffer (1 .. Debug_Buffer_Len));
      end if;

   end Add_Call_Information;

end A4G.Vcheck;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ S T A N D                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                            $Revision: 15117 $
--                                                                          --
--           Copyright (c) 2002, Free Software Foundation, Inc.             --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  We need this renaming because the GNAT Stand package and the ASIS A4G.Stand
--  package conflict if mentioned in the same context clause. This renaming
--  seems to be the cheapest way to correct the old bad choice of the name
--  of the ASIS package (A4G.Stand)

with A4G.Stand;

package A4G.A_Stand renames A4G.Stand;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  asf-beans-injections -- Injection of parameters, headers, cookies in beans
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with ASF.Cookies;
package body ASF.Beans.Injections is

   --  ------------------------------
   --  Inject the request header whose name is defined by Descriptor.Param.
   --  ------------------------------
   procedure Header (Bean       : in out Util.Beans.Basic.Bean'Class;
                     Descriptor : in Inject_Type;
                     Request    : in ASF.Requests.Request'Class) is
      Value : constant String := Request.Get_Header (Descriptor.Param.all);
   begin
      Bean.Set_Value (Descriptor.Name.all, Util.Beans.Objects.To_Object (Value));
   end Header;

   --  ------------------------------
   --  Inject the request query string parameter whose name is defined by Descriptor.Param.
   --  ------------------------------
   procedure Query_Param (Bean       : in out Util.Beans.Basic.Bean'Class;
                          Descriptor : in Inject_Type;
                          Request    : in ASF.Requests.Request'Class) is
      Value : constant String := Request.Get_Parameter (Descriptor.Param.all);
   begin
      Bean.Set_Value (Descriptor.Name.all, Util.Beans.Objects.To_Object (Value));
   end Query_Param;

   --  ------------------------------
   --  Inject the request cookie whose name is defined by Descriptor.Param.
   --  ------------------------------
   procedure Cookie (Bean       : in out Util.Beans.Basic.Bean'Class;
                     Descriptor : in Inject_Type;
                     Request    : in ASF.Requests.Request'Class) is
      Cookies : constant ASF.Cookies.Cookie_Array := Request.Get_Cookies;
   begin
      for I in Cookies'Range loop
         if ASF.Cookies.Get_Name (Cookies (I)) = Descriptor.Param.all then
            Bean.Set_Value (Descriptor.Name.all,
                            Util.Beans.Objects.To_Object (ASF.Cookies.Get_Value (Cookies (I))));
         end if;
      end loop;
   end Cookie;

   --  ------------------------------
   --  Inject the request URI path component whose position is defined by Descriptor.Pos.
   --  ------------------------------
   procedure Path_Param (Bean       : in out Util.Beans.Basic.Bean'Class;
                         Descriptor : in Inject_Type;
                         Request    : in ASF.Requests.Request'Class) is
      URI   : constant String := Request.Get_Path_Info;
      Pos   : Natural := URI'First;
      Count : Natural := Descriptor.Pos;
      Next_Pos : Natural;
   begin
      while Count > 0 and Pos < URI'Last loop
         Next_Pos := Util.Strings.Index (URI, '/', Pos + 1);
         Count := Count - 1;
         if Count = 0 then
            if Next_Pos = 0 then
               Next_Pos := URI'Last;
            else
               Next_Pos := Next_Pos - 1;
            end if;
            Bean.Set_Value (Descriptor.Name.all,
                            Util.Beans.Objects.To_Object (URI (Pos + 1 .. Next_Pos)));
            return;
         end if;
         Pos := Next_Pos;
      end loop;
   end Path_Param;

   --  ------------------------------
   --  Inject into the Ada bean a set of information extracted from the request object.
   --  The value is obtained from a request header, a cookie, a query string parameter or
   --  from a URI path component.  The value is injected by using the bean operation
   --  <tt>Set_Value</tt>.
   --  ------------------------------
   procedure Inject (Into    : in out Util.Beans.Basic.Bean'Class;
                     List    : in Inject_Array_Type;
                     Request : in ASF.Requests.Request'Class) is
   begin
      for I in List'Range loop
         List (I).Handler (Into, List (I), Request);
      end loop;
   end Inject;

end ASF.Beans.Injections;

Implement the Inject, Header, Path_Param, Cookie and Query_Param procedures


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

with Ada.Finalization;
with Ada.Strings.Unbounded;

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

with Util.Log.Loggers;
with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
   begin
      null;
   end Add_Policy;

   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      null;
   end Add_Permission;

   --  Get the security controller associated with the permission index <b>Index</b>.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

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

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      package Role_Config is
        new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Role_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
   begin
      null;
   end Finalize;

end Security.Policies;

Implement the Security.Policies package

Implement the Security.Policies package


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

with Ada.Unchecked_Deallocation;

package body Util.Beans.Basic.Lists is

   --  ------------------------------
   --  Initialize the list bean.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out List_Bean) is
      Bean : constant Readonly_Bean_Access := Object.Current'Unchecked_Access;
   begin
      Object.Row := Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   function Get_Count (From : in List_Bean) return Natural is
   begin
      return Natural (Vectors.Length (From.List));
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is
   begin
      From.Current := Vectors.Element (From.List, Index - 1);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   function Get_Row (From : in List_Bean) return Util.Beans.Objects.Object is
   begin
      return From.Row;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (Integer (From.List.Length));
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Deletes the list bean
   --  ------------------------------
   procedure Free (List : in out Util.Beans.Basic.Readonly_Bean_Access) is

      procedure Free is
        new Ada.Unchecked_Deallocation (List_Bean'Class,
                                        List_Bean_Access);
   begin
      if List.all in List_Bean'Class then
         declare
            L : List_Bean_Access := List_Bean (List.all)'Unchecked_Access;
         begin
            Free (L);
            List := null;
         end;
      end if;
   end Free;

end Util.Beans.Basic.Lists;

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

with Ada.Unchecked_Deallocation;

package body Util.Beans.Basic.Lists is

   --  ------------------------------
   --  Initialize the list bean.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out List_Bean) is
      Bean : constant Readonly_Bean_Access := Object.Current'Unchecked_Access;
   begin
      Object.Row := Util.Beans.Objects.To_Object (Bean, Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   function Get_Count (From : in List_Bean) return Natural is
   begin
      return Natural (Vectors.Length (From.List));
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is
   begin
      From.Current_Index := Index;
      From.Current := Vectors.Element (From.List, Index - 1);
   end Set_Row_Index;

   --  ------------------------------
   --  Returns the current row index.
   --  ------------------------------
   function Get_Row_Index (From : in List_Bean) return Natural is
   begin
      return From.Current_Index;
   end Get_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   function Get_Row (From : in List_Bean) return Util.Beans.Objects.Object is
   begin
      return From.Row;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (Integer (From.List.Length));
      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Current_Index);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Deletes the list bean
   --  ------------------------------
   procedure Free (List : in out Util.Beans.Basic.Readonly_Bean_Access) is

      procedure Free is
        new Ada.Unchecked_Deallocation (List_Bean'Class,
                                        List_Bean_Access);
   begin
      if List.all in List_Bean'Class then
         declare
            L : List_Bean_Access := List_Bean (List.all)'Unchecked_Access;
         begin
            Free (L);
            List := null;
         end;
      end if;
   end Free;

end Util.Beans.Basic.Lists;

Implement the Get_Row_Index Recognize 'rowIndex' as a name for the list bean to return the current row index