------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . C O N T T . S D                          --
--                                                                          --
--                                 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.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Exceptions;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;

with Asis.Errors;               use Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.GNAT_Int;
with A4G.A_Output;              use A4G.A_Output;
with A4G.Contt.TT;              use A4G.Contt.TT;
with A4G.Contt.UT;              use A4G.Contt.UT;
with A4G.CU_Info2;              use A4G.CU_Info2;
with A4G.Defaults;              use A4G.Defaults;
with A4G.Vcheck;                use A4G.Vcheck;

with Atree;
with Lib;
with Output;                    use Output;
with Sinfo;                     use Sinfo;

package body A4G.Contt.SD is

   ------------------------------------
   -- Local Subprograms  (new stuff) --
   ------------------------------------

   --  Do we need some of these local subprograms as the interface
   --  subprograms of this package?

   --  Is this package the right location for these subprograms?

   procedure Scan_Search_Path (C : Context_Id);
   --  Scans the tree search path and stores the names of the tree file
   --  candidates in the context tree table.

   procedure Scan_Tree_List (C : Context_Id);
   --  This procedure is supposed to be called for One_tree and N_Trees
   --  Context processing modes, therefore the Parameters string associated
   --  with C should contain at least one tree name. It scans the list of tree
   --  file names which have been extracted from the Parameters string when
   --  making the association for C. For each tree file name checks if the
   --  file exists and stores existing files in the context tree table. In case
   --  if this check fails, raises ASIS_Failed if C was defined as "-C1"
   --  ("one tree") context, or generates Asis Warning for "-CN" Context.
   --  This procedure does not reset a context.

   procedure Read_and_Check_New
     (C       : Context_Id;
      Tree    : Tree_Id;
      Success : out Boolean);
   --  Tries to read in Tree and to check if this tree is compile-only.
   --  if both of these attempts are successful, sets Success ON and
   --  sets Current_Tree as Tree. If either of these actions fails, then
   --  depending on the Context operation mode, either raises ASIS_Failed
   --  and forms the Diagnosis string on behalf on Asis.Ada_Environments.Open,
   --  or only sets Success OFF, in both cases Current_Context and Current_Tree
   --  are set to nil values.

   procedure Process_Unit_New (U : Unit_Number_Type);
   --  Does the general unit processing in one-pass Context opening. If this
   --  unit is "new", it creates the new entry in the unit table and checks,
   --  if the unit in the tree is consistent with the unit source (if needed).
   --  If U corresponds to a "known" unit, it makes the consistency check.
   --  If this procedure raises ASIS_Failed, it forms the Diagnosis string
   --  on behalf on Asis.Ada_Environments.Open
   --  ????????

   procedure Investigate_Unit_New
     (C   : Context_Id;
      U   : Unit_Id;
      U_N : Unit_Number_Type);
   --  Computes the basic unit attributes for U_N and stores them for the
   --  ASIS unit U in the ASIS Context C.

   procedure Store_Tree (Path : String);
   --  Stores the full name of the tree file in the Context Tree table for
   --  the current Context. It supposes, that when it is called,
   --  Namet.Name_Table contains the name of the tree file to be stored,
   --  but without any directory information, and Path contains the path to
   --  the tree search directory (followed by directory separator) where this
   --  file was found.

   ---------------------------
   -- Investigate_Trees_New --
   ---------------------------

   procedure Investigate_Trees_New (C : Context_Id) is
      Success : Boolean := False;
      --  flag indicating if the next tree file has been successfully read in
      Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
   begin
      --  here we have all the names of tree files stored in the tree table
      --  for C
      for T in First_Tree_Id .. Last_Tree (C) loop
         Read_and_Check_New (C, T, Success);

         if Success then
            Get_Name_String (C, T);
            Change_Dir (Dir_Name (A_Name_Buffer (1 .. A_Name_Len)));

            Register_Units;
            Scan_Units_New;

            Change_Dir (Current_Dir);
         end if;

      end loop;
   end Investigate_Trees_New;

   --------------------------
   -- Investigate_Unit_New --
   --------------------------

   procedure Investigate_Unit_New
     (C   : Context_Id;
      U   : Unit_Id;
      U_N : Unit_Number_Type)
   is
      Top : constant Node_Id := Lib.Cunit (U_N);
      --  pointer to the N_Compilation_Unit node for U in the currently
      --  accessed tree
   begin

      Set_S_F_Name_and_Origin (C, U, Top);
      Check_Source_Consistency (C, U);

      Set_Kind_and_Class      (C, U, Top);
      Get_Ada_Name            (Top);
      Set_Ada_Name            (U);
      Set_Is_Main_Unit        (C, U, Is_Main (Top, Kind (C, U)));
      Set_Is_Body_Required    (C, U, Sinfo.Body_Required (Top));

      Set_Dependencies        (C, U, Top);

   end Investigate_Unit_New;

   ----------------------
   -- Process_Unit_New --
   ----------------------

   procedure Process_Unit_New (U : Unit_Number_Type) is
      Cont         : constant Context_Id := Get_Current_Cont;
      Include_Unit : Boolean             := False;
      Current_Unit : Unit_Id;
   begin
      Namet.Get_Decoded_Name_String (Lib.Unit_Name (U));
      Set_Norm_Ada_Name_String_With_Check (U, Include_Unit);

      if not Include_Unit then
         return;
      end if;

      Current_Unit := Name_Find (Cont);
      --  all the units in the current tree are already registered, therefore
      --  Current_Unit should not be Nil_Unit

      if Already_Processed (Cont, Current_Unit) then
         Check_Consistency   (Cont, Current_Unit, U);
         --  Append_Tree_To_Unit (Cont, Current_Unit);
      else
         Investigate_Unit_New (Cont, Current_Unit, U);
      end if;
   end Process_Unit_New;

   ------------------------
   -- Read_and_Check_New --
   ------------------------

   procedure Read_and_Check_New
     (C       : Context_Id;
      Tree    : Tree_Id;
      Success : out Boolean)
   is
      Tree_File_D : File_Descriptor;

   begin
      --  Special processing for GNSA mode:
      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Set_Current_Cont (C);
            Set_Current_Tree (Tree);
            Success := True;
            return;
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      Get_Name_String (C, Tree);
      A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL;
      Tree_File_D := Open_Read (A_Name_Buffer'Address, Binary);

      A4G.GNAT_Int.Tree_In_With_Version_Check (Tree_File_D, C, Success);

      Set_Current_Cont (C);
      Set_Current_Tree (Tree);

   exception
      when Program_Error |
           ASIS_Failed   =>

         Set_Current_Cont (Nil_Context_Id);
         Set_Current_Tree (Nil_Tree);

         raise;
      when Ex : others =>

         --  If we are here, we are definitely having a serious problem:
         --  we have a tree file which is version-compartible with ASIS,
         --  and we can not read it because of some unknown reason.

         Set_Current_Cont (Nil_Context_Id);
         Set_Current_Tree (Nil_Tree);

         --  debug stuff...
         if Debug_Flag_O    or else
            Debug_Lib_Model or else
            Debug_Mode
         then
            Write_Str ("The tree file ");
            Write_Str (A_Name_Buffer (1 .. A_Name_Len));
            Write_Str (" was not read in and checked successfully");
            Write_Eol;
            Write_Str (Ada.Exceptions.Exception_Name (Ex));
            Write_Str (" was raised");
            Write_Eol;
            Write_Str ("Exception message: ");
            Write_Str (Ada.Exceptions.Exception_Message (Ex));
            Write_Eol;
         end if;

         Report_ASIS_Bug
           (Query_Name  => "A4G.Contt.SD.Read_and_Check_New" &
                           " (tree file " &
                           A_Name_Buffer (1 .. A_Name_Len) & ")",
            Ex          => Ex);
   end Read_and_Check_New;

   --------------------
   -- Scan_Tree_List --
   --------------------

   procedure Scan_Tree_List (C : Context_Id) is
      Cont_Mode   : constant Context_Mode := Context_Processing_Mode (C);
      Tree_List   : Tree_File_List_Ptr renames
        Contexts.Table (C).Context_Tree_Files;

      GNSA_Tree_Name : constant String := "GNSA-created tree";
      --  Can be used for -C1 COntext only.

--      Success : Boolean;
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Name_Len := GNSA_Tree_Name'Length;
            Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name;
            Store_Tree ("");

            return;
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      for I in Tree_List'Range loop

         exit when Tree_List (I) = null;

         if not Is_Regular_File (Tree_List (I).all) then

--            --  A loop needed to deal with possible raise conditions

--            Success := False;

--            for J in 1 .. 100 loop
--               if Is_Regular_File (Tree_List (I).all) then
--                  Success := True;
--                  exit;
--               end if;

--               delay 0.05;
--            end loop;

--            if not Success then

            if Cont_Mode  = One_Tree then
               Set_Error_Status
                 (Status    => Asis.Errors.Use_Error,
                  Diagnosis => "Asis.Ada_Environments.Open:"
                             &  ASIS_Line_Terminator
                             & "tree file "
                             & Tree_List (I).all
                             & " does not exist");
               raise ASIS_Failed;
            elsif Cont_Mode = N_Trees then
               ASIS_Warning
                  (Message => "Asis.Ada_Environments.Open: "
                             &  ASIS_Line_Terminator
                             & "tree file "
                             & Tree_List (I).all
                             & " does not exist",
                   Error   => Use_Error);
            end if;
--            end if;

         else
            Name_Len := Tree_List (I)'Length;
            Name_Buffer (1 .. Name_Len) := Tree_List (I).all;
            Store_Tree ("");
         end if;

      end loop;

   end Scan_Tree_List;

   ----------------------
   -- Scan_Search_Path --
   ----------------------

   procedure Scan_Search_Path (C : Context_Id) is
      Curr_Dir    : GNAT.Directory_Operations.Dir_Type;
      Search_Path : constant Directory_List_Ptr :=
        Contexts.Table (C).Tree_Path;

      procedure Scan_Dir (Path : String);
      --  scans tree files in Curr_Dir. Puts in the Name Table all
      --  the files having names of the form *.at?, which have not been
      --  scanned before. Sets the global variable Last_Tree_File equal to
      --  the Name_Id of the last scanned tree file. The names of the tree
      --  files stores in the Name Table are also stored in the ASIS tree
      --  table with the directory information passed as the actual for Path
      --  parameter

      procedure Read_Tree_File
        (Dir  : in out GNAT.Directory_Operations.Dir_Type;
         Str  : out String;
         Last : out Natural);
      --  This procedure is the modification of GNAT.Directory_Operations.Read
      --  which reads only tree file entries from the directory. A Tree file
      --  is any file having the extension '.[aA][dD][tT]' (We are
      --  considering upper case letters because of "semi-case-sensitiveness"
      --  of Windows 95/98/NT.)

      procedure Read_Tree_File
        (Dir  : in out GNAT.Directory_Operations.Dir_Type;
         Str  : out String;
         Last : out Natural)
      is
         function Is_Tree_File return Boolean;
         --  Checks if the file name stored in Str is the name of some tree
         --  file. This function assumes that Str'First is 1, and that
         --  Last > 0

         function Is_Tree_File return Boolean is
            Result : Boolean := False;
         begin

            if Last >= 5                     and then
               Str (Last - 3) = '.'          and then

               (Str (Last) = 't' or else
                Str (Last) = 'T')            and then

               (Str (Last - 1) = 'd' or else
                Str (Last - 1) = 'D')        and then

               (Str (Last - 2) = 'a' or else
                Str (Last - 2) = 'A')
            then
               Result := True;
            end if;

            return Result;

         end Is_Tree_File;

      begin
         GNAT.Directory_Operations.Read (Dir, Str, Last);
         while Last > 0 loop
            exit when Is_Tree_File;
            GNAT.Directory_Operations.Read (Dir, Str, Last);
         end loop;

      end Read_Tree_File;

      procedure Scan_Dir (Path : String) is
         T_File        : Name_Id;
         Is_First_Tree : Boolean := True;
      begin
         --  looking for the first tree file in this directory

         Read_Tree_File
           (Dir  => Curr_Dir,
            Str  => Namet.Name_Buffer,
            Last => Namet.Name_Len);

         while Namet.Name_Len > 0 loop
            T_File := Name_Find;

            if Is_First_Tree then
               Is_First_Tree := False;
               First_Tree_File := T_File;
            end if;

            if T_File > Last_Tree_File then
               Last_Tree_File := T_File;
               Store_Tree (Path);
            end if;

            Read_Tree_File
              (Dir  => Curr_Dir,
               Str  => Namet.Name_Buffer,
               Last => Namet.Name_Len);

         end loop;

      end Scan_Dir;

   begin  --  Scan_Search_Path
      if Search_Path = null then
         GNAT.Directory_Operations.Open (Curr_Dir, "." & Directory_Separator);
         Scan_Dir ("");
         GNAT.Directory_Operations.Close (Curr_Dir);
      else

         for I in 1 .. Search_Path'Last loop
            GNAT.Directory_Operations.Open (Curr_Dir, Search_Path (I).all);
            Scan_Dir (Search_Path (I).all);
            GNAT.Directory_Operations.Close (Curr_Dir);
         end loop;

      end if;

      if Use_Default_Trees (C) then

         for J in First_Dir_Id .. ASIS_Tree_Search_Directories.Last loop

            GNAT.Directory_Operations.Open
              (Curr_Dir,
               ASIS_Tree_Search_Directories.Table (J).all);

            Scan_Dir (ASIS_Tree_Search_Directories.Table (J).all);
            GNAT.Directory_Operations.Close (Curr_Dir);

         end loop;

      end if;

   end Scan_Search_Path;

   -------------------------
   -- Scan_Tree_Files_New --
   -------------------------

   procedure Scan_Tree_Files_New (C : Context_Id) is
      C_Mode : constant Context_Mode := Context_Processing_Mode (C);

      GNSA_Tree_Name : constant String := "GNSA-created tree";
      --  Can be used for -C1 Context only
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Name_Len := GNSA_Tree_Name'Length;
            Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name;
            Store_Tree ("");

            return;
            --  to avoid GNAT Name Table corruption
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      --  first, initialization which is (may be?) common for all context
      --  modes:
      First_Tree_File := First_Name_Id;
      Last_Tree_File  := First_Name_Id - 1;
      Namet.Initialize;

      --  now for different context modes we call individual scan procedures.
      --  all of them first put names of tree files into the GNAT Name table
      --  and then transfer them into Context tree table, but we cannot
      --  factor this out because of the differences in processing a search
      --  path (if any) and forming the full names of the tree files

      case C_Mode is
         when All_Trees =>
            Scan_Search_Path (C);
         when One_Tree | N_Trees =>
            Scan_Tree_List (C);
            --  all the tree file names have already been stored in the
            --  context tree table when association parameters were processed
            null;
         when Partition =>
            Not_Implemented_Yet ("Scan_Tree_Files_New (Partition)");
      end case;

      --  debug output:...
      if Debug_Flag_O    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Scanning tree files for Context ");
         Write_Int (Int (C));
         Write_Eol;
         if Context_Processing_Mode (C) = All_Trees then

            if Last_Tree_File < First_Tree_File then
               Write_Str ("   no tree file has been found");
               Write_Eol;
            else
               Write_Str ("   the content of the Name Table is:");
               Write_Eol;

               for I in First_Tree_File .. Last_Tree_File loop
                  Get_Name_String (I);
                  Write_Str ("      ");
                  Write_Str (Name_Buffer (1 .. Name_Len));
                  Write_Eol;
               end loop;

            end if;

         else
            Write_Str ("Trees already stored in the tree table:");
            Write_Eol;

            for Tr in First_Tree_Id .. Last_Tree (C) loop
               Get_Name_String (C, Tr);
               Write_Str ("   " & A_Name_Buffer (1 ..  A_Name_Len));
               Write_Eol;
            end loop;

         end if;
      end if;

   end Scan_Tree_Files_New;

   --------------------
   -- Scan_Units_New --
   --------------------

   procedure Scan_Units_New is
      Main_Unit_Id : Unit_Id;
      Next_Unit_Id : Unit_Id;
      Include_Unit : Boolean := False;
   begin

      for N_Unit in Main_Unit .. Lib.Last_Unit loop

         if Atree.Present (Lib.Cunit (N_Unit)) then
            Process_Unit_New (N_Unit);
         end if;

      end loop;

      --  And here we collect compilation dependencies for the main unit in
      --  the tree:

      Namet.Get_Decoded_Name_String (Lib.Unit_Name (Main_Unit));
      Set_Norm_Ada_Name_String_With_Check (Main_Unit, Include_Unit);

      if not Include_Unit then
         return;
      end if;

      Main_Unit_Id := Name_Find (Current_Context);

      for N_Unit in Main_Unit .. Lib.Last_Unit loop

         if Atree.Present (Lib.Cunit (N_Unit)) then

            Namet.Get_Decoded_Name_String (Lib.Unit_Name (N_Unit));
            Set_Norm_Ada_Name_String_With_Check (N_Unit, Include_Unit);

            if Include_Unit then
               Next_Unit_Id := Name_Find (Current_Context);

               Add_To_Elmt_List
                 (Unit => Next_Unit_Id,
                  List =>
                     Unit_Table.Table (Main_Unit_Id).Compilation_Dependencies);
            end if;

         end if;

      end loop;

      Unit_Table.Table (Main_Unit_Id).Main_Tree := Current_Tree;
      Set_Main_Unit_Id (Main_Unit_Id);

   end Scan_Units_New;

   ----------------
   -- Store_Tree --
   ----------------

   procedure Store_Tree (Path : String) is
      New_Tree : Tree_Id;
      --  we do not need it, but Allocate_Tree_Entry is a function...
      pragma Warnings (Off, New_Tree);
   begin
      if Path = "" then
         Set_Name_String (Normalize_Pathname (Name_Buffer (1 .. Name_Len)));
      else
         Set_Name_String
           (Normalize_Pathname
              (Path & Directory_Separator & Name_Buffer (1 .. Name_Len)));
      end if;

      New_Tree := Allocate_Tree_Entry;
   end Store_Tree;

end A4G.Contt.SD;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . S O R 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.      --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.Heap_Sort_G;

separate (Lib)
procedure Sort (Tbl : in out Unit_Ref_Table) is

   T : array (0 .. Integer (Tbl'Last - Tbl'First + 1)) of Unit_Number_Type;
   --  Actual sort is done on this copy of the array with 0's origin
   --  subscripts. Location 0 is used as a temporary by the sorting algorithm.
   --  Also the addressing of the table is more efficient with 0's origin,
   --  even though we have to copy Tbl back and forth.

   function Lt_Uname (C1, C2 : Natural) return Boolean;
   --  Comparison routine for comparing Unames. Needed by the sorting routine

   procedure Move_Uname (From : Natural; To : Natural);
   --  Move routine needed by the sorting routine below

   package Sorting is new GNAT.Heap_Sort_G (Move_Uname, Lt_Uname);

   --------------
   -- Lt_Uname --
   --------------

   function Lt_Uname (C1, C2 : Natural) return Boolean is
   begin
      --  Preprocessing data and definition files are not sorted, they are
      --  at the bottom of the list. They are recognized because they are
      --  the only ones without a Unit_Name.

      if Units.Table (T (C1)).Unit_Name = No_Unit_Name then
         return False;

      elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then
         return True;

      else
         return
           Uname_Lt
             (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name);
      end if;
   end Lt_Uname;

   ----------------
   -- Move_Uname --
   ----------------

   procedure Move_Uname (From : Natural; To : Natural) is
   begin
      T (To) := T (From);
   end Move_Uname;

--  Start of processing for Sort

begin
   if T'Last > 0 then
      for I in 1 .. T'Last loop
         T (I) := Tbl (Int (I) - 1 + Tbl'First);
      end loop;

      Sorting.Sort (T'Last);

   --  Sort is complete, copy result back into place

      for I in 1 .. T'Last loop
         Tbl (Int (I) - 1 + Tbl'First) := T (I);
      end loop;
   end if;
end Sort;

Add GNAT file for ASIS

Add GNAT file for ASIS


-----------------------------------------------------------------------
--  ado-cache -- Simple cache management
--  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 Ada.Unchecked_Deallocation;
package body ADO.Caches is

   --  --------------------
   --  Expand the name from the given group into a target parameter value to be used in
   --  the SQL query.  The expander can look in a cache or in some configuration to find
   --  the value associated with the name and return it.  The Expander can return a
   --  T_NULL when a value is not found or it may also raise some exception.
   --  --------------------
   overriding
   function Expand (Instance : in Cache_Manager;
                    Group    : in String;
                    Name     : in String) return ADO.Parameters.Parameter is
      use type Ada.Strings.Unbounded.Unbounded_String;
      C : Cache_Type_Access := Instance.First;
   begin
      while C /= null loop
         if C.Name = Group then
            return C.Expand (Name);
         end if;
         C := C.Next;
      end loop;
      raise No_Value;
   end Expand;

   --  --------------------
   --  Insert a new cache in the manager.  The cache is identified by the given name.
   --  --------------------
   procedure Add_Cache (Manager : in out Cache_Manager;
                        Name    : in String;
                        Cache   : in Cache_Type_Access) is
   begin
      Cache.Next    := Manager.First;
      Cache.Name    := Ada.Strings.Unbounded.To_Unbounded_String (Name);
      Manager.First := Cache;
   end Add_Cache;

   --  --------------------
   --  Finalize the cache manager releasing every cache group.
   --  --------------------
   overriding
   procedure Finalize (Manager : in out Cache_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Cache_Type'Class,
                                        Name   => Cache_Type_Access);
      Cache : Cache_Type_Access;
   begin
      loop
         Cache := Manager.First;
         exit when Cache = null;
         Manager.First := Cache.Next;
         Free (Cache);
      end loop;
   end Finalize;

end ADO.Caches;

Implement the cache manager operation

Implement the cache manager operation


-----------------------------------------------------------------------
--  Filters Tests - Unit tests for ASF.Filters
--  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.
-----------------------------------------------------------------------

package body ASF.Filters.Tests is

   --  ------------------------------
   --  Increment the counter each time Do_Filter is called.
   --  ------------------------------
   procedure Do_Filter (F        : in Test_Filter;
                        Request  : in out Requests.Request'Class;
                        Response : in out Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
   begin
      F.Count.all := F.Count.all + 1;
      ASF.Servlets.Do_Filter (Chain => Chain, Request => Request, Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Initialize the test filter.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Test_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
      pragma Unreferenced (Context);
   begin
      Server.Count := Server.Counter'Unchecked_Access;
   end Initialize;

end ASF.Filters.Tests;

Implement a test filter that counts the number of times it is traversed


-----------------------------------------------------------------------
--  security-filters-oauth -- OAuth Security filter
--  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 Ada.Strings.Unbounded;

with ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with Security.OAuth.Servers; use Security.OAuth;
with Security.Policies;  use Security;

--  The ASF.Security.Filters.OAuth package provides a servlet filter that
--  implements the RFC 6749 "Accessing Protected Resources" part: it extracts the OAuth
--  access token, verifies the grant and the permission.  The servlet filter implements
--  the RFC 6750 "OAuth 2.0 Bearer Token Usage".
--
package ASF.Security.Filters.OAuth is

   --  RFC 2617 HTTP header for authorization.
   AUTHORIZATION_HEADER_NAME    : constant String := "Authorization";

   --  RFC 2617 HTTP header for failed authorization.
   WWW_AUTHENTICATE_HEADER_NAME : constant String := "WWW-Authenticate";

   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   overriding
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  Set the permission manager that must be used to verify the permission.
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access);

   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class);

private

   type Auth_Filter is new ASF.Filters.Filter with record
      Manager   : Policies.Policy_Manager_Access;
      Realm     : Servers.Auth_Manager_Access;
      Realm_URL : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Security.Filters.OAuth;

Declare the OAuth child package with the Auth_Filter for the definition and representation of the OAuth server side filter to verify the access token when an API call is made


-----------------------------------------------------------------------
--  measure -- Benchmark tools
--  Copyright (C) 2008, 2009, 2010, 2011, 2012, 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.Task_Attributes;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
with GNAT.Calendar.Time_IO;

with Util.Streams.Buffered;
package body Util.Measures is

   ISO_DATE_TIME : constant GNAT.Calendar.Time_IO.Picture_String := "%Y-%m-%d %H:%M:%S";

   procedure Free is
     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Measure, Measure_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String, String_Access);

   package Task_Context is new Ada.Task_Attributes
     (Measure_Set_Access, null);

   function Format (D : in Duration) return String;

   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String;

   --  ------------------------------
   --  Disable collecting measures on the measure set.
   --  ------------------------------
   procedure Disable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := False;
   end Disable;

   --  ------------------------------
   --  Enable collecting measures on the measure set.
   --  ------------------------------
   procedure Enable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := True;
   end Enable;

   --  ------------------------------
   --  Set the per-thread measure set.
   --  ------------------------------
   procedure Set_Current (Measures : in Measure_Set_Access) is
   begin
      Task_Context.Set_Value (Measures);
   end Set_Current;

   --  ------------------------------
   --  Get the per-thread measure set.
   --  ------------------------------
   function Get_Current return Measure_Set_Access is
   begin
      return Task_Context.Value;
   end Get_Current;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  When writing the measures, the measure set is cleared.  It is safe
   --  to write measures while other measures are being collected.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in out Util.Streams.Texts.Print_Stream'Class) is

      use Util.Streams.Buffered;

      procedure Dump_XML (Item : in Measure_Access);

      procedure Dump_XML (Item : in Measure_Access) is
         Time  : constant String := Format (Item.Time);
      begin
         Stream.Write ("<time count=""");
         Stream.Write (Item.Count);
         Stream.Write (""" time=""");
         Stream.Write (Time (Time'First + 1 .. Time'Last));
         Stream.Write (""" title=""");
         Util.Streams.Texts.TR.Escape_Java_Script (Into => Buffered_Stream (Stream),
                                                   Content => Item.Name.all);
         Stream.Write ("""/>");
         Stream.Write (ASCII.LF);
      end Dump_XML;

      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;

   begin
      Measures.Data.Steal_Map (Buckets, TS, TE);
      Stream.Write ("<measures title=""");
      Util.Streams.Texts.TR.Escape_Java_Script (Into    => Buffered_Stream (Stream),
                                                Content => Title);
      Stream.Write (""" start=""");
      Stream.Write (TS, ISO_DATE_TIME);
      Stream.Write (""" end=""");
      Stream.Write (TE, ISO_DATE_TIME);
      Stream.Write (""">");
      if Buckets /= null then
         begin
            for I in Buckets'Range loop
               declare
                  Next : Measure_Access;
                  Node : Measure_Access := Buckets (I);
               begin
                  while Node /= null loop
                     Dump_XML (Node);
                     Free (Node.Name);
                     Next := Node.Next;
                     Free (Node);
                     Node := Next;
                  end loop;
               end;
            end loop;

         exception
            when others =>
               Free (Buckets);
               raise;
         end;
         Free (Buckets);
      end if;
      Stream.Write ("</measures>");
   end Write;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in Ada.Text_IO.File_Type) is

      Buffer : aliased Util.Streams.Buffered.Buffered_Stream;
      Output : Util.Streams.Texts.Print_Stream;

   begin
      Buffer.Initialize (Size => 128 * 1024);
      Output.Initialize (To => Buffer'Unchecked_Access);
      Write (Measures, Title, Output);
      Output.Flush;
      Ada.Text_IO.Put_Line (Stream, Util.Streams.Texts.To_String (Buffer));
   end Write;

   --  ------------------------------
   --  Dump  an XML result with the measures in a file.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Path     : in String) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => File, Name => Path);
      Write (Measures, Title, File);
      Ada.Text_IO.Close (File);
   exception
      when others =>
         if Ada.Text_IO.Is_Open (File) then
            Ada.Text_IO.Close (File);
         end if;
         raise;
   end Write;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the per-thread measure set under the given measure
   --  title.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     Title : in String;
                     Count : in Positive := 1) is
      Measures : constant Measure_Set_Access := Task_Context.Value;
   begin
      if Measures /= null and then Measures.Enabled then
         Report (Measures.all, S, Title, Count);
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the measure set under the given measure title.
   --  ------------------------------
   procedure Report (Measures : in out Measure_Set;
                     S        : in out Stamp;
                     Title    : in String;
                     Count    : in Positive := 1) is
      use Ada.Calendar;
   begin
      if Measures.Enabled then
         declare
            D : constant Duration := Ada.Calendar.Clock - S.Start;
         begin
            Measures.Data.Add (Title, D, Count);
         end;
         S.Start := Ada.Calendar.Clock;
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  The report is written in the file with the given title.  The duration is
   --  expressed in the unit defined in <tt>Unit</tt>.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     File  : in out Ada.Text_IO.File_Type;
                     Title : in String;
                     Unit  : in Unit_Type := Microseconds) is
      use Ada.Calendar;

      D : constant Duration := Ada.Calendar.Clock - S.Start;
   begin
      Ada.Text_IO.Put (File, Title);
      Ada.Text_IO.Put (File, Format (D, Unit));
      S.Start := Ada.Calendar.Clock;
   end Report;

   protected body Measure_Data is

      --  ------------------------------
      --  Get the measures and clear to start a new set of measures.
      --  Return in Time_Start and Time_End the period of time.
      --  ------------------------------
      procedure Steal_Map (Result     : out Buckets_Access;
                           Time_Start : out Ada.Calendar.Time;
                           Time_End   : out Ada.Calendar.Time) is
      begin
         Result     := Buckets;
         Time_Start := Start;
         Start      := Ada.Calendar.Clock;
         Time_End   := Start;
         Buckets    := null;
      end Steal_Map;

      --  ------------------------------
      --  Add the measure
      --  ------------------------------
      procedure Add (Title : in String;
                     D     : in Duration;
                     Count : in Positive := 1) is

         use Ada.Containers;
         use Ada.Calendar;

         Pos  : Hash_Type;
         Node : Measure_Access;
      begin
         if Buckets = null then
            Buckets := new Buckets_Type (0 .. 256);
         end if;
         Pos := Ada.Strings.Hash (Title) mod Buckets'Length;
         Node := Buckets (Pos);
         while Node /= null loop
            if Node.Name'Length = Title'Length
              and then Node.Name.all = Title then
               Node.Count := Node.Count + Count;
               Node.Time := Node.Time + D;
               return;
            end if;
            Node := Node.Next;
         end loop;
         Buckets (Pos) := new Measure '(Name => new String '(Title),
                                        Time  => D,
                                        Count => Count,
                                        Next  => Buckets (Pos));
      end Add;

   end Measure_Data;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D : Duration) return String is
   begin
      if D < 0.000_001 then
         return Duration'Image (D * 1_000_000_000) & "ns";
      elsif D < 0.001 then
         return Duration'Image (D * 1_000_000) & "us";
      elsif D < 1.0 then
         return Duration'Image (D * 1_000) & "ms";
      else
         return Duration'Image (D) & "s";
      end if;
   end Format;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String is
   begin
      case Unit is
         when Seconds =>
            return Duration'Image (D);

         when Milliseconds =>
            return Duration'Image (D * 1_000);

         when Microseconds =>
            return Duration'Image (D * 1_000_000);

         when Nanoseconds =>
            return Duration'Image (D * 1_000_000_000);

      end case;
   end Format;

   --  ------------------------------
   --  Finalize the measures and release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Measures : in out Measure_Set) is
      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;
   begin
      --  When deleting the measure set, we have to release the buckets and measures
      --  that were allocated.  We could call Write but we don't know where
      --  the measures have to be written.
      Measures.Data.Steal_Map (Buckets, TS, TE);
      if Buckets /= null then
         for I in Buckets'Range loop
            declare
               Next : Measure_Access;
               Node : Measure_Access := Buckets (I);
            begin
               while Node /= null loop
                  Free (Node.Name);
                  Next := Node.Next;
                  Free (Node);
                  Node := Next;
               end loop;
            end;
         end loop;
         Free (Buckets);
      end if;
   end Finalize;

end Util.Measures;

-----------------------------------------------------------------------
--  measure -- Benchmark tools
--  Copyright (C) 2008, 2009, 2010, 2011, 2012, 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.Task_Attributes;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
with GNAT.Calendar.Time_IO;

with Util.Streams.Buffered;
package body Util.Measures is

   ISO_DATE_TIME : constant GNAT.Calendar.Time_IO.Picture_String := "%Y-%m-%d %H:%M:%S";

   procedure Free is
     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Measure, Measure_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String, String_Access);

   package Task_Context is new Ada.Task_Attributes
     (Measure_Set_Access, null);

   function Format (D : in Duration) return String;

   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String;

   --  ------------------------------
   --  Disable collecting measures on the measure set.
   --  ------------------------------
   procedure Disable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := False;
   end Disable;

   --  ------------------------------
   --  Enable collecting measures on the measure set.
   --  ------------------------------
   procedure Enable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := True;
   end Enable;

   --  ------------------------------
   --  Set the per-thread measure set.
   --  ------------------------------
   procedure Set_Current (Measures : in Measure_Set_Access) is
   begin
      Task_Context.Set_Value (Measures);
   end Set_Current;

   --  ------------------------------
   --  Get the per-thread measure set.
   --  ------------------------------
   function Get_Current return Measure_Set_Access is
   begin
      return Task_Context.Value;
   end Get_Current;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  When writing the measures, the measure set is cleared.  It is safe
   --  to write measures while other measures are being collected.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in out Util.Streams.Texts.Print_Stream'Class) is

      use Util.Streams.Buffered;

      procedure Dump_XML (Item : in Measure_Access);

      procedure Dump_XML (Item : in Measure_Access) is
         Total : constant String := Format (Item.Time);
         Time  : constant String := Format (Item.Time / Item.Count);
      begin
         Stream.Write ("<time count=""");
         Stream.Write (Item.Count);
         Stream.Write (""" time=""");
         Stream.Write (Time (Time'First + 1 .. Time'Last));
         if Item.Count > 1 then
            Stream.Write (""" total=""");
            Stream.Write (Total (Total'First + 1 .. Total'Last));
         end if;
         Stream.Write (""" title=""");
         Util.Streams.Texts.TR.Escape_Java_Script (Into => Buffered_Stream (Stream),
                                                   Content => Item.Name.all);
         Stream.Write ("""/>");
         Stream.Write (ASCII.LF);
      end Dump_XML;

      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;

   begin
      Measures.Data.Steal_Map (Buckets, TS, TE);
      Stream.Write ("<measures title=""");
      Util.Streams.Texts.TR.Escape_Java_Script (Into    => Buffered_Stream (Stream),
                                                Content => Title);
      Stream.Write (""" start=""");
      Stream.Write (TS, ISO_DATE_TIME);
      Stream.Write (""" end=""");
      Stream.Write (TE, ISO_DATE_TIME);
      Stream.Write (""">");
      if Buckets /= null then
         begin
            for I in Buckets'Range loop
               declare
                  Next : Measure_Access;
                  Node : Measure_Access := Buckets (I);
               begin
                  while Node /= null loop
                     Dump_XML (Node);
                     Free (Node.Name);
                     Next := Node.Next;
                     Free (Node);
                     Node := Next;
                  end loop;
               end;
            end loop;

         exception
            when others =>
               Free (Buckets);
               raise;
         end;
         Free (Buckets);
      end if;
      Stream.Write ("</measures>");
   end Write;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in Ada.Text_IO.File_Type) is

      Buffer : aliased Util.Streams.Buffered.Buffered_Stream;
      Output : Util.Streams.Texts.Print_Stream;

   begin
      Buffer.Initialize (Size => 128 * 1024);
      Output.Initialize (To => Buffer'Unchecked_Access);
      Write (Measures, Title, Output);
      Output.Flush;
      Ada.Text_IO.Put_Line (Stream, Util.Streams.Texts.To_String (Buffer));
   end Write;

   --  ------------------------------
   --  Dump  an XML result with the measures in a file.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Path     : in String) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => File, Name => Path);
      Write (Measures, Title, File);
      Ada.Text_IO.Close (File);
   exception
      when others =>
         if Ada.Text_IO.Is_Open (File) then
            Ada.Text_IO.Close (File);
         end if;
         raise;
   end Write;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the per-thread measure set under the given measure
   --  title.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     Title : in String;
                     Count : in Positive := 1) is
      Measures : constant Measure_Set_Access := Task_Context.Value;
   begin
      if Measures /= null and then Measures.Enabled then
         Report (Measures.all, S, Title, Count);
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the measure set under the given measure title.
   --  ------------------------------
   procedure Report (Measures : in out Measure_Set;
                     S        : in out Stamp;
                     Title    : in String;
                     Count    : in Positive := 1) is
      use Ada.Calendar;
   begin
      if Measures.Enabled then
         declare
            D : constant Duration := Ada.Calendar.Clock - S.Start;
         begin
            Measures.Data.Add (Title, D, Count);
         end;
         S.Start := Ada.Calendar.Clock;
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  The report is written in the file with the given title.  The duration is
   --  expressed in the unit defined in <tt>Unit</tt>.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     File  : in out Ada.Text_IO.File_Type;
                     Title : in String;
                     Unit  : in Unit_Type := Microseconds) is
      use Ada.Calendar;

      D : constant Duration := Ada.Calendar.Clock - S.Start;
   begin
      Ada.Text_IO.Put (File, Title);
      Ada.Text_IO.Put (File, Format (D, Unit));
      S.Start := Ada.Calendar.Clock;
   end Report;

   protected body Measure_Data is

      --  ------------------------------
      --  Get the measures and clear to start a new set of measures.
      --  Return in Time_Start and Time_End the period of time.
      --  ------------------------------
      procedure Steal_Map (Result     : out Buckets_Access;
                           Time_Start : out Ada.Calendar.Time;
                           Time_End   : out Ada.Calendar.Time) is
      begin
         Result     := Buckets;
         Time_Start := Start;
         Start      := Ada.Calendar.Clock;
         Time_End   := Start;
         Buckets    := null;
      end Steal_Map;

      --  ------------------------------
      --  Add the measure
      --  ------------------------------
      procedure Add (Title : in String;
                     D     : in Duration;
                     Count : in Positive := 1) is

         use Ada.Containers;
         use Ada.Calendar;

         Pos  : Hash_Type;
         Node : Measure_Access;
      begin
         if Buckets = null then
            Buckets := new Buckets_Type (0 .. 256);
         end if;
         Pos := Ada.Strings.Hash (Title) mod Buckets'Length;
         Node := Buckets (Pos);
         while Node /= null loop
            if Node.Name'Length = Title'Length
              and then Node.Name.all = Title then
               Node.Count := Node.Count + Count;
               Node.Time := Node.Time + D;
               return;
            end if;
            Node := Node.Next;
         end loop;
         Buckets (Pos) := new Measure '(Name => new String '(Title),
                                        Time  => D,
                                        Count => Count,
                                        Next  => Buckets (Pos));
      end Add;

   end Measure_Data;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D : in Duration) return String is
   begin
      if D < 0.000_001 then
         return Duration'Image (D * 1_000_000_000) (1 .. 6) & " ns";
      elsif D < 0.001 then
         return Duration'Image (D * 1_000_000) (1 .. 6) & " us";
      elsif D < 1.0 then
         return Duration'Image (D * 1_000) (1 .. 6) & " ms";
      else
         return Duration'Image (D) (1 .. 6) & " s";
      end if;
   end Format;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String is
   begin
      case Unit is
         when Seconds =>
            return Duration'Image (D);

         when Milliseconds =>
            return Duration'Image (D * 1_000);

         when Microseconds =>
            return Duration'Image (D * 1_000_000);

         when Nanoseconds =>
            return Duration'Image (D * 1_000_000_000);

      end case;
   end Format;

   --  ------------------------------
   --  Finalize the measures and release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Measures : in out Measure_Set) is
      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;
   begin
      --  When deleting the measure set, we have to release the buckets and measures
      --  that were allocated.  We could call Write but we don't know where
      --  the measures have to be written.
      Measures.Data.Steal_Map (Buckets, TS, TE);
      if Buckets /= null then
         for I in Buckets'Range loop
            declare
               Next : Measure_Access;
               Node : Measure_Access := Buckets (I);
            begin
               while Node /= null loop
                  Free (Node.Name);
                  Next := Node.Next;
                  Free (Node);
                  Node := Next;
               end loop;
            end;
         end loop;
         Free (Buckets);
      end if;
   end Finalize;

end Util.Measures;

Improve the format of duration in performance reports Report the total time and the single call time


-----------------------------------------------------------------------
--  asf-components-widgets-inputs -- Input widget components
--  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 Ada.Strings.Unbounded;

with ASF.Components.Html.Messages;
with ASF.Applications.Messages.Vectors;

with Util.Beans.Objects;
package body ASF.Components.Widgets.Inputs is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Render the input field title.
   --  ------------------------------
   procedure Render_Title (UI      : in UIInput;
                           Writer  : in Response_Writer_Access;
                           Context : in out Faces_Context'Class) is
      Title : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "title");
   begin
      Writer.Start_Element ("dt");
      Writer.Write (Title);
      Writer.End_Element ("dt");
   end Render_Title;

   --  ------------------------------
   --  Render the input component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIInput;
                           Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
         Style    : constant String := UI.Get_Attribute ("styleClass", Context);
      begin
         Writer.Start_Element ("dl");
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Writer.Write_Attribute ("class", Style & " awa-error");
         elsif Style'Length > 0 then
            Writer.Write_Attribute ("class", Style);
         end if;
         UI.Render_Title (Writer, Context);
         Writer.Start_Element ("dd");
         UI.Render_Input (Context);
      end;
   end Encode_Begin;

   --  ------------------------------
   --  Render the end of the input component.  Closes the DL/DD list.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIInput;
                         Context : in out Faces_Context'Class) is
      use ASF.Components.Html.Messages;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      --  Render the error message associated with the input field.
      declare
         Id       : constant String := To_String (UI.Get_Client_Id);
         Writer   : constant Response_Writer_Access := Context.Get_Response_Writer;
         Messages : constant ASF.Applications.Messages.Vectors.Cursor := Context.Get_Messages (Id);
      begin
         if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
            Write_Message (UI, ASF.Applications.Messages.Vectors.Element (Messages),
                           SPAN_NO_STYLE, False, True, Context);
         end if;
         Writer.End_Element ("dd");
         Writer.End_Element ("dl");
      end;
   end Encode_End;

end ASF.Components.Widgets.Inputs;

Implement the input text field widget

Implement the input text field widget


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

package body Babel.Files.Maps is

   --  ------------------------------
   --  Find the file with the given name in the file map.
   --  ------------------------------
   function Find (From : in File_Map;
                  Name : in String) return File_Cursor is
   begin
      return From.Find (Key => Name'Unrestricted_Access);
   end Find;

end Babel.Files.Maps;

Implement the Find operation

Implement the Find operation


-----------------------------------------------------------------------
--  security-auth-oauth -- OAuth based authentication
--  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 Security.OAuth.Clients;
private package Security.Auth.OAuth is

   --  ------------------------------
   --  OAuth Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OAuth authorization process.
   type Manager is abstract 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 OAuth access token and retrieve information about the user.
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is abstract;

private

   type Manager is abstract new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
      Scope     : Unbounded_String;
      App       : Security.OAuth.Clients.Application;
   end record;

end Security.Auth.OAuth;

Define the OAuth based authorization

Define the OAuth based authorization


-----------------------------------------------------------------------
--  asf-parts -- ASF Parts
--  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 EL.Methods.Proc_In;

package ASF.Parts.Upload_Method is
  new EL.Methods.Proc_In (Param1_Type => ASF.Parts.Part'Class);

Define a method and binding for an Ada bean to receive an uploaded file


-----------------------------------------------------------------------
--  wiki-streams-html-builders -- Wiki writer to a string builder
--  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.Streams.Builders;

--  == Writer interfaces ==
--  The <tt>Wiki.Writers</tt> package defines the interfaces used by the renderer to write
--  their outputs.
--
package Wiki.Streams.Html.Builders is

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with private;
   type Html_Output_Builder_Stream_Access is access all Html_Output_Builder_Stream'Class;

   overriding
   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString);

   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String);

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString);

   overriding
   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String);

   overriding
   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String);

   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString);

private

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with record
      --  Whether an XML element must be closed (that is a '>' is necessary)
      Close_Start : Boolean := False;
   end record;

end Wiki.Streams.Html.Builders;

Declare the Wiki.Streams.Html.Builders package for the HTML output stream


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

-----------------------------------------------------------------------
--  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 for dynamo

Update the documentation for dynamo