------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . G E T _ U N I T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2011, 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.Characters.Handling;   use Ada.Characters.Handling;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib;               use GNAT.OS_Lib;

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

with Asis.Set_Get;              use  Asis.Set_Get;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.A_Opt;                 use A4G.A_Opt;
with A4G.U_Conv;                use A4G.U_Conv;
with A4G.Contt.Dp;              use A4G.Contt.Dp;
with A4G.Contt.SD;              use A4G.Contt.SD;
with A4G.Contt.TT;              use A4G.Contt.TT;
with A4G.Contt.UT;              use A4G.Contt.UT; use A4G.Contt;
with A4G.Defaults;              use A4G.Defaults;
with A4G.GNAT_Int;              use A4G.GNAT_Int;
with A4G.Vcheck;                use A4G.Vcheck;

with Output;                    use Output;

package body A4G.Get_Unit is

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

   function Convert_To_String (Wide_Name : Wide_String) return String;
   --  Takes the name (of a compilation unit) and converts it into String
   --  following the GNAT encoding rules as described in Namet.

   -----------------------
   -- Convert_To_String --
   -----------------------

   function Convert_To_String (Wide_Name : Wide_String) return String is
   begin

      if Is_String (Wide_Name) then
         return To_String (Wide_Name);
      else
         Not_Implemented_Yet ("Wide_Character in Unit name");
      end if;

   end Convert_To_String;

   ----------------------------
   -- Fetch_Unit_By_Ada_Name --
   ----------------------------

   function Fetch_Unit_By_Ada_Name
     (Name      : String;
      Norm_Name : String;
      Context   : Context_Id;
      Spec      : Boolean)
      return Unit_Id
   is
      Result_Unit_Id : Unit_Id;
      Result_Tree    : Tree_Id;

      File_Name : String_Access;
      --  We use File_Name to obtain the source file name according to
      --  the GNAT file name rules (including the krunching rules)

      Predefined : Boolean := False;
      Success    : Boolean := False;

      Source_File  : String_Access;
      --  source to compile, contains all the path information
      Tree_File_N  : String_Access;
      --  tree output file to be retrieved (name)
      Tree_File_D  : File_Descriptor;
      --  tree output file to be retrieved (file descriptor)

      Cont_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (Context);

      procedure Get_Source_File;
      --  This procedure creates the value of Source_File using the values
      --  of Name and Spec. The procedure first tries to get the file
      --  containing the body regardless of the value of the Spec parameter.
      --  The idea is to get for Spec => True the tree file containing both
      --  the spec and the body of the compilation unit. If we get the tree
      --  file for the spec only, then latter on we may get into
      --  the following problem - the attempt to get the body of the
      --  compilation unit will create the tree file for the body, and
      --  this tree file will have the same name. As a result, all the
      --  references into the tree for spec will become erroneous, and
      --  we will have the problem similar to what was reported as 7504-002.
      --
      --  ??? All this "compile-on-the-fly" Context mode becomes a real
      --  mess. May be, we have to get rid of it???

      procedure Get_Source_File is
      begin
         --  The code is really awfull, but probably it would be better to
         --  get rid of the "compila-on-the-fly" mode, then to polish
         --  the code.

         File_Name := Source_From_Unit_Name (Name, False);
         --  if needed, the name is krunched here (??? may be, we can already
         --  forget about systems with the limitations on the file name
         --  length???)
         --  Note also, that ASIS cannot work with files which names override
         --  the standard GNAT file name convention as a result of
         --  Source_File_Name pragma.

         Source_File := Locate_In_Search_Path
                          (C         => Context,
                           File_Name => To_String (File_Name),
                           Dir_Kind  => Source);

         if Source_File = null then
            Source_File := Locate_Default_File
                             (File_Name => File_Name,
                              Dir_Kind  => Source);
         end if;

         if Source_File /= null then
            return;
         elsif Spec then
            File_Name := Source_From_Unit_Name (Name, True);

            Source_File := Locate_In_Search_Path
                             (C         => Context,
                              File_Name => To_String (File_Name),
                              Dir_Kind  => Source);

            if Source_File = null then
               Source_File := Locate_Default_File
                                (File_Name => File_Name,
                                 Dir_Kind  => Source);
            end if;

         end if;

         if Source_File = null and then
            Is_Predefined_File_Name (File_Name)
            --  not GNAT, but ASIS Is_Predefined_File_Name function is called
            --  here!
         then
            --  if File_Name is the name of a predefined unit, we shall try
            --  the default source search path. See also
            --  A4G.Contt.Set_Predefined_Units
            File_Name := Source_From_Unit_Name (Name, False);
            Predefined  := True;
            Source_File := Locate_Default_File (File_Name, Source);

            if Source_File = null then
               File_Name := Source_From_Unit_Name (Name, True);
               Source_File := Locate_Default_File (File_Name, Source);
            end if;

         end if;

      end Get_Source_File;

   begin
      --  we start from looking for a unit in the Unit Name Table
      Set_Name_String (Norm_Name);
      Result_Unit_Id := Name_Find (Context);

      if Result_Unit_Id /= Nil_Unit then
         return Result_Unit_Id;
      elsif Cont_Tree_Mode = Pre_Created then
         if Norm_Name = "standard%s" then
            --  For Standard, we have to search twice - first for possible
            --  redefinition of Standard, then - for predefined Standard
            return Standard_Id;
         else
            return Nil_Unit;
         end if;
      end if;

      if Spec then
         --  The idea is to avoid non-needed recompilations in case if we
         --  already have the (tree for the) corresponding body, see F823-027.
         A_Name_Buffer (A_Name_Len) := 'b';
         Result_Unit_Id := Name_Find (Context);

         if Result_Unit_Id /= Nil_Unit then
            return Nil_Unit;
         end if;

      end if;

      --  We can be here only if Context was associated in On_The_Fly or Mixed
      --  tree processing mode mode, and we have failed to find the required
      --  unit among units which are already known to ASIS. Therefore, we
      --  have to (try to) create the tree by compiling the source:

      Get_Source_File;

      if Source_File = null then
         if Debug_Mode then
            Write_Str ("Fetch_Unit_By_Ada_Name: cannot locate a source file ");
            Write_Str ("for " & Name);
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      --  And trying to compile - Source_File contains the reference
      --  to the existing source file which has been already successfully
      --  located in the Context:

      if Debug_Mode then
         Write_Str ("Fetch_Unit_By_Ada_Name: "
                  & "Trying to create a tree on the fly:");
         Write_Eol;
         Write_Str ("Source file is " & To_String (Source_File));
         Write_Eol;
      end if;

      Create_Tree (Source_File   => Source_File,
                   Context       => Context,
                   Is_Predefined => Predefined,
                   Success       => Success);

      if not Success then

         if Debug_Mode then
            Write_Str ("Failure...");
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      if Debug_Mode then
         Write_Str ("Success...");
         Write_Eol;
      end if;

      --  here we have a new tree, successfully created just here. We will
      --  read it in, then we will investigate it just in the same way as
      --  during opening a Context and then we look into the unit table for
      --  the needed unit again

      Tree_File_N := Tree_From_Source_Name (File_Name);
      --  ??? IT WOULD BE BETTER TO USE STRIP_DIRECTORY (SOURCE_FILE)
      --  INSTEAD OF FILE_NAME HERE!!!!!

      Tree_File_D := Open_Read (Tree_File_N.all'Address, Binary);

      begin
         if Debug_Mode then
            Write_Str ("Fetch_Unit_By_Ada_Name: trying to read in a tree...");
            Write_Eol;
         end if;

         Tree_In_With_Version_Check (Tree_File_D, Context, Success);

         if Success then

            if Debug_Mode then
               Write_Str ("Fetch_Unit_By_Ada_Name: a tree is read in...");
               Write_Eol;
            end if;

         else
            --  This should never happen!

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "A4G.Get_Unit.Fetch_Unit_By_Ada_Name:"
               &  ASIS_Line_Terminator
               & "problems reading tree file "
               & To_String (Tree_File_N));

            raise ASIS_Failed;
         end if;

      exception
         when Program_Error |
              ASIS_Failed   =>

            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 ("A4G.Get_Unit.Fetch_Unit_By_Ada_Name:");
               Write_Eol;
               Write_Str ("Cannot read the tree file ");
               Write_Str (To_String (Tree_File_N));
               Write_Str (" newly created for a source file ");
               Write_Str (To_String (Source_File));
               Write_Eol;
            end if;

            Report_ASIS_Bug
              (Query_Name  => "A4G.Get_Unit.Fetch_Unit_By_Ada_Name" &
                              " (tree file " & To_String (Tree_File_N) & ")",
               Ex          => Ex);
      end;

      Set_Name_String (To_String (Tree_File_N));
      Set_Current_Cont (Context);
      Result_Tree := Allocate_Tree_Entry;
      Set_Current_Tree (Result_Tree);

      --  here we have to investigate the newly created tree:

      if Tree_Processing_Mode (Context) = Incremental then

         begin
            NB_Save;
            Register_Units (Set_First_New_Unit => True);
            Scan_Units_New;

            Set_All_Dependencies (Use_First_New_Unit => True);

            Reorder_Trees (Context);
         exception

            when Inconsistent_Incremental_Context =>
               --  Erase the old Context information
               Increase_ASIS_OS_Time;
               Pre_Initialize (Context);
               A4G.Contt.Initialize (Context);

               --  We still have one good tree
               Result_Tree := Allocate_Tree_Entry;
               NB_Restore;
               Set_Current_Tree (Result_Tree);

               --  And we have to extract the information from this tree
               Register_Units;
               Scan_Units_New;
               Set_All_Dependencies;
         end;

      else
         --  For old "on the fly" and mixed mode no enhansment
         Register_Units;
         Scan_Units_New;
      end if;

      --  and now - the final attempt to get the needed unit. We have to reset
      --  the name buffer - it may be changed by Scan_Units_New:
      Set_Name_String (Norm_Name);
      Result_Unit_Id := Name_Find (Context);

      if Result_Unit_Id = Nil_Unit
        and then
         Norm_Name = "standard%s"
      then
         --  For Standard, we have to search twice - first for possible
         --  redefinition of Standard, then - for predefined Standard
         Result_Unit_Id := Standard_Id;
      end if;

      return Result_Unit_Id;

   end Fetch_Unit_By_Ada_Name;

   -----------------------------------
   -- Get_Main_Unit_Tree_On_The_Fly --
   -----------------------------------

   function Get_Main_Unit_Tree_On_The_Fly
     (Start_Unit : Unit_Id;
      Cont       : Context_Id;
      Spec       : Boolean)
      return       Unit_Id
   is
      Start_CU : constant Asis.Compilation_Unit :=
        Get_Comp_Unit (Start_Unit, Cont);

      Result_Unit_Id : Unit_Id;
      Result_Tree    : Tree_Id;

      File_Name : String_Access;
      --  We use File_Name to obtain the source file name according to
      --  the GNAT file name rules (including the krunching rules)

      Predefined : Boolean := False;
      Success    : Boolean := False;

      S_File_To_Compile : String_Access;
      --  source to compile, contains all the path information

      Tmp_S_File, Tmp_S_File1 : String_Access;

      Tree_File_N  : String_Access;
      --  tree output file to be retrieved (name)
      Tree_File_D  : File_Descriptor;
      --  tree output file to be retrieved (file descriptor)

      procedure Get_Source_File_To_Compile;
      --  This procedure creates the value of Source_File using the values
      --  of Start_Unit and Spec. If Spec is ON, the full source name of
      --  Start_Unit is used. If Spec is OFF, we try to create the source
      --  file name from the unit name by applying the standard GNAT file
      --  naming rules. This is the weak point of the implementation, because
      --  this does not wor for non-standard names

      procedure Get_Source_File_To_Compile is
      begin

         if Spec then
            S_File_To_Compile :=
               new String'(Source_File (Start_CU) & ASCII.NUL);
         else
            --  The first thing to do is to try to locate the file with the
            --  name computed on the base of the standard GNAT name rules

            File_Name := Source_From_Unit_Name (Unit_Name (Start_CU), False);

            S_File_To_Compile := Locate_In_Search_Path
                             (C         => Cont,
                              File_Name => To_String (File_Name),
                              Dir_Kind  => Source);

            if  S_File_To_Compile = null then
               --  Two possibilities:
               --  - Start_Unit is a predefined unit
               --  - Try to convert spec name into unit body name and to
               --    locate it

               Tmp_S_File := new String'(Source_File (Start_CU));

               Tmp_S_File (Tmp_S_File'Last) := 'b';

               Tmp_S_File1 := new String'(Base_Name (Tmp_S_File.all));

               if not Is_Predefined_File_Name (Tmp_S_File1) then

                  S_File_To_Compile := Locate_In_Search_Path
                                   (C         => Cont,
                                    File_Name => Tmp_S_File.all,
                                    Dir_Kind  => Source);
               else
                  Predefined        := True;
                  S_File_To_Compile :=
                     Locate_Default_File (Tmp_S_File, Source);
               end if;

            end if;

         end if;

      end Get_Source_File_To_Compile;

   begin

      Get_Source_File_To_Compile;

      if S_File_To_Compile = null then
         if Debug_Mode then
            Write_Str ("Get_Main_Unit_Tree_On_The_Fly: cannot create a main ");
            Write_Str ("tree for " & Unit_Name (Start_CU));
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      --  Now we try to compile - Source_File contains the reference
      --  to the existing source file which has been already successfully
      --  located in the Context:

      if Debug_Mode then
         Write_Str ("Get_Main_Unit_Tree_On_The_Fly: "
                  & "Trying to create a main tree on the fly:");
         Write_Eol;
         Write_Str ("Source file is " & S_File_To_Compile.all);
         Write_Eol;
      end if;

      Create_Tree (Source_File   => S_File_To_Compile,
                   Context       => Cont,
                   Is_Predefined => Predefined,
                   Success       => Success);

      if not Success then

         if Debug_Mode then
            Write_Str ("Failure...");
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      if Debug_Mode then
         Write_Str ("Success...");
         Write_Eol;
      end if;

      --  Now we have a new tree, successfully created just here. We have to
      --  add it to the incremental Context

      Tree_File_N := new String'(Base_Name (S_File_To_Compile.all));

      Tree_File_N (Tree_File_N'Last - 1) := 't';
      --  ??? What about non-standart file names????

      Tree_File_D := Open_Read (Tree_File_N.all'Address, Binary);

      begin
         if Debug_Mode then
            Write_Str ("Get_Main_Unit_Tree_On_The_Fly: read in a tree...");
            Write_Eol;
         end if;

         Tree_In_With_Version_Check (Tree_File_D, Cont, Success);

         if Success then

            if Debug_Mode then
               Write_Str ("Get_Main_Unit_Tree_On_The_Fly: done...");
               Write_Eol;
            end if;

         else
            --  This should never happen!

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly:"
               &  ASIS_Line_Terminator
               & "problems reading tree file "
               & To_String (Tree_File_N));

            raise ASIS_Failed;
         end if;

      exception
         when Program_Error |
              ASIS_Failed   =>

            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 ("A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly:");
               Write_Eol;
               Write_Str ("Cannot read the tree file ");
               Write_Str (To_String (Tree_File_N));
               Write_Str (" newly created for a source file ");
               Write_Str (S_File_To_Compile.all);
               Write_Eol;
            end if;

            Report_ASIS_Bug
              (Query_Name  => "A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly" &
                              " (tree file " & To_String (Tree_File_N) & ")",
               Ex          => Ex);
      end;

      Set_Name_String (To_String (Tree_File_N));

      Set_Current_Cont (Cont);
      Result_Tree := Allocate_Tree_Entry;
      Set_Current_Tree (Result_Tree);

      --  here we have to investigate the newly created tree:

      begin
         NB_Save;
         Register_Units (Set_First_New_Unit => True);
         Scan_Units_New;

         Set_All_Dependencies (Use_First_New_Unit => True);

         Reorder_Trees (Cont);
      exception

         when Inconsistent_Incremental_Context =>
            --  Erase the old Context information
            Increase_ASIS_OS_Time;
            Pre_Initialize (Cont);
            A4G.Contt.Initialize (Cont);

            --  We still have one good tree
            Result_Tree := Allocate_Tree_Entry;
            NB_Restore;
            Set_Current_Tree (Result_Tree);

            --  And we have to extract the information from this tree
            Register_Units;
            Scan_Units_New;
            Set_All_Dependencies;
      end;

      --  and now - forming the result Unit_Id

      if Spec then
         Result_Unit_Id := Start_Unit;
      else
         Result_Unit_Id :=  Get_Body (Cont, Start_Unit);
      end if;

      return Result_Unit_Id;

   end Get_Main_Unit_Tree_On_The_Fly;

   ------------------
   -- Get_One_Unit --
   ------------------

   function Get_One_Unit
     (Name    : Wide_String;
      Context : Context_Id;
      Spec    : Boolean)
      return Unit_Id
   is
      Unit_Name      : constant String := Convert_To_String (Name);
      Name_Length    : constant Natural                   := Unit_Name'Length;
      Norm_Unit_Name : String (1 .. Name_Length + 2); -- "+ 2" for %(s|b)

      Result_Id      : Unit_Id;

      Is_Unit_Name   : Boolean := False;

   begin

      --  first of all, we have to check if Name can really be
      --  treated as Ada unit name:

      if Name_Length = 0 then
         return Nil_Unit;
      end if;

      Get_Norm_Unit_Name (U_Name           => Unit_Name,
                          N_U_Name         => Norm_Unit_Name,
                          Spec             => Spec,
                          May_Be_Unit_Name => Is_Unit_Name);

      if not Is_Unit_Name then
         return Nil_Unit;
      end if;

      --  Now we are sure that Name has the syntax structure of the Ada
      --  unit name, and we have to check whether ASIS has already got
      --  to know about this unit in its Unit Table, Norm_Unit_Name has
      --  already been prepared for the corresponding search in the
      --  Unit Table. If this check fails, we will
      --  have to try to compile the Unit from its source:
      Result_Id := Fetch_Unit_By_Ada_Name
                        (Name      => Unit_Name,
                         Norm_Name => Norm_Unit_Name,
                         Context   => Context,
                         Spec      => Spec);

      return Result_Id;

   end Get_One_Unit;

end A4G.Get_Unit;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  awa-storages-tests -- Unit tests for storages module
--  Copyright (C) 2018, 2019, 2020 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.Strings;

with ADO;
with Servlet.Streams;
with ASF.Tests;
with AWA.Tests.Helpers.Users;
with AWA.Storages.Beans;
with AWA.Storages.Models;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with AWA.Services.Contexts;
with Security.Contexts;

package body AWA.Storages.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;
   use type AWA.Storages.Services.Storage_Service_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Storages.Beans.Create",
                       Test_Create_Document'Access);
      Caller.Add_Test (Suite, "Test AWA.Storages.Servlets (missing)",
                       Test_Missing_Document'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the wiki as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String) is
      pragma Unreferenced (Title);

      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/documents.html",
                        "storage-anonymous-list.html");
      ASF.Tests.Assert_Contains (T, "List of pages", Reply,
                                 "Wiki list recent page is invalid");
   end Verify_Anonymous;

   --  ------------------------------
   --  Verify that the wiki lists contain the given page.
   --  ------------------------------
   procedure Verify_List_Contains (T    : in out Test;
                                   Page : in String) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/documents.html",
                        "storage-list.html");
      ASF.Tests.Assert_Contains (T, "Documents of the workspace", Reply,
                                 "List of documents is invalid");
   end Verify_List_Contains;

   --  ------------------------------
   --  Test access to the blog as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("", "");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of document by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Document (T : in out Test) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      AWA.Tests.Helpers.Users.Login ("test-storage@test.com", Request);
      Request.Set_Parameter ("folder-name", "Test Folder Name");
      Request.Set_Parameter ("storage-folder-create-form", "1");
      Request.Set_Parameter ("storage-folder-create-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/storages/forms/folder-create.html", "folder-create-form.html");

      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response after folder creation");

      ASF.Tests.Do_Get (Request, Reply, "/storages/documents.html",
                        "storage-list.html");
      ASF.Tests.Assert_Contains (T, "Documents of the workspace", Reply,
                                 "List of documents is invalid (title)");
      ASF.Tests.Assert_Contains (T, "Test Folder Name", Reply,
                                 "List of documents is invalid (content)");
   end Test_Create_Document;

   --  ------------------------------
   --  Test getting a document which does not exist.
   --  ------------------------------
   procedure Test_Missing_Document (T : in out Test) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/files/12345345/view/missing.pdf",
                        "storage-file-missing.html");
      ASF.Tests.Assert_Matches (T, ".title.Page not found./title.", Reply,
                                "Page for a missing document is invalid",
                                Servlet.Responses.SC_NOT_FOUND);
   end Test_Missing_Document;

end AWA.Storages.Tests;

Implement the new test for storage module to simulate web requests


-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with Util.Serialize.IO;
generic
   type Element_Type is limited private;
   type Element_Type_Access is access all Element_Type;
   type Fields is (<>);

   --  The Set_Member procedure will be called by the mapper when a mapping associated
   --  with Field is recognized.  The Value holds the value that was extracted
   --  according to the mapping.  The Set_Member procedure should save in the target
   --  object Into the value.  If an error is detected, the procedure can raise the
   --  Util.Serialize.Mappers.Field_Error exception.  The exception message will be
   --  reported by the IO reader as an error.
   with procedure Set_Member (Into   : in out Element_Type;
                              Field  : in Fields;
                              Value  : in Util.Beans.Objects.Object);

   --  Adding a second function/procedure as generic parameter makes the
   --  Vector_Mapper generic package fail to instantiate a valid package.
   --  The failure occurs in Vector_Mapper in the 'with package Element_Mapper' instantiation.
   --
--        with function Get_Member (From  : in Element_Type;
--                                  Field : in Fields) return Util.Beans.Objects.Object;
package Util.Serialize.Mappers.Record_Mapper is

   type Get_Member_Access is
     access function (From  : in Element_Type;
                      Field : in Fields) return Util.Beans.Objects.Object;

   --  Procedure to give access to the Element_Type object from the context.
   type Process_Object is not null
   access procedure (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                     Attr    : in Mapping'Class;
                     Value   : in Util.Beans.Objects.Object;
                     Process : not null
                     access procedure (Attr  : in Mapping'Class;
                                       Item  : in out Element_Type;
                                       Value : in Util.Beans.Objects.Object));

   type Proxy_Object is not null
   access procedure (Attr    : in Mapping'Class;
                     Element : in out Element_Type;
                     Value   : in Util.Beans.Objects.Object);

   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.  This operation will call
   --  the package parameter function of the same name.
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.
   type Element_Data is new Util.Serialize.Contexts.Data with private;
   type Element_Data_Access is access all Element_Data'Class;

   --  Get the element object.
   function Get_Element (Data : in Element_Data) return Element_Type_Access;

   --  Set the element object.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Finalize the object when it is removed from the reader context.
   --  If the Release parameter was set, the target element will be freed.
   overriding
   procedure Finalize (Data : in out Element_Data);

   --  -----------------------
   --  Record mapper
   --  -----------------------
   type Mapper is new Util.Serialize.Mappers.Mapper with private;
   type Mapper_Access is access all Mapper'Class;

   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object);

   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields);

   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object);

   --  Clone the Handler instance and get a copy of that single object.
   overriding
   function Clone (Handler : in Mapper) return Util.Serialize.Mappers.Mapper_Access;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access);

   procedure Bind (Into    : in out Mapper;
                   From    : in Mapper_Access);

   function Get_Getter (From : in Mapper) return Get_Member_Access;

   --  Set the element in the context.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   procedure Add_Default_Mapping (Into : in out Mapper);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Util.Serialize.Mappers.Mapper'Class;
                    Getter  : in Get_Member_Access;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

private

   type Element_Data is new Util.Serialize.Contexts.Data with record
      Element : Element_Type_Access;
      Release : Boolean;
   end record;

   type Mapper is new Util.Serialize.Mappers.Mapper with record
      Execute    : Proxy_Object := Set_Member'Access;
      Get_Member : Get_Member_Access;
   end record;

   type Attribute_Mapping is new Mapping with record
      Index   : Fields;
   end record;
   type Attribute_Mapping_Access is access all Attribute_Mapping'Class;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   type Proxy_Mapper is new Mapper with null record;
   type Proxy_Mapper_Access is access all Proxy_Mapper'Class;

   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False)
                         return Util.Serialize.Mappers.Mapper_Access;

end Util.Serialize.Mappers.Record_Mapper;

-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Beans.Objects;
with Util.Serialize.IO;
generic
   type Element_Type (<>) is limited private;
   type Element_Type_Access is access all Element_Type;
   type Fields is (<>);

   --  The Set_Member procedure will be called by the mapper when a mapping associated
   --  with Field is recognized.  The Value holds the value that was extracted
   --  according to the mapping.  The Set_Member procedure should save in the target
   --  object Into the value.  If an error is detected, the procedure can raise the
   --  Util.Serialize.Mappers.Field_Error exception.  The exception message will be
   --  reported by the IO reader as an error.
   with procedure Set_Member (Into   : in out Element_Type;
                              Field  : in Fields;
                              Value  : in Util.Beans.Objects.Object);

   --  Adding a second function/procedure as generic parameter makes the
   --  Vector_Mapper generic package fail to instantiate a valid package.
   --  The failure occurs in Vector_Mapper in the 'with package Element_Mapper' instantiation.
   --
--        with function Get_Member (From  : in Element_Type;
--                                  Field : in Fields) return Util.Beans.Objects.Object;
package Util.Serialize.Mappers.Record_Mapper is

   type Get_Member_Access is
     access function (From  : in Element_Type;
                      Field : in Fields) return Util.Beans.Objects.Object;

   --  Procedure to give access to the Element_Type object from the context.
   type Process_Object is not null
   access procedure (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                     Attr    : in Mapping'Class;
                     Value   : in Util.Beans.Objects.Object;
                     Process : not null
                     access procedure (Attr  : in Mapping'Class;
                                       Item  : in out Element_Type;
                                       Value : in Util.Beans.Objects.Object));

   type Proxy_Object is not null
   access procedure (Attr    : in Mapping'Class;
                     Element : in out Element_Type;
                     Value   : in Util.Beans.Objects.Object);

   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.  This operation will call
   --  the package parameter function of the same name.
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   --  -----------------------
   --  Data context
   --  -----------------------
   --  Data context to get access to the target element.
   type Element_Data is new Util.Serialize.Contexts.Data with private;
   type Element_Data_Access is access all Element_Data'Class;

   --  Get the element object.
   function Get_Element (Data : in Element_Data) return Element_Type_Access;

   --  Set the element object.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Finalize the object when it is removed from the reader context.
   --  If the Release parameter was set, the target element will be freed.
   overriding
   procedure Finalize (Data : in out Element_Data);

   --  -----------------------
   --  Record mapper
   --  -----------------------
   type Mapper is new Util.Serialize.Mappers.Mapper with private;
   type Mapper_Access is access all Mapper'Class;

   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object);

   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields);

   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object);

   --  Clone the Handler instance and get a copy of that single object.
   overriding
   function Clone (Handler : in Mapper) return Util.Serialize.Mappers.Mapper_Access;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access);

   procedure Bind (Into    : in out Mapper;
                   From    : in Mapper_Access);

   function Get_Getter (From : in Mapper) return Get_Member_Access;

   --  Set the element in the context.  When Release is set, the element Element
   --  will be freed when the reader context is deleted (by Finalize).
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access;
                          Release : in Boolean := False);

   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   procedure Add_Default_Mapping (Into : in out Mapper);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

   --  Write the element on the stream using the mapper description.
   procedure Write (Handler : in Util.Serialize.Mappers.Mapper'Class;
                    Getter  : in Get_Member_Access;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type);

private

   type Element_Data is new Util.Serialize.Contexts.Data with record
      Element : Element_Type_Access;
      Release : Boolean;
   end record;

   type Mapper is new Util.Serialize.Mappers.Mapper with record
      Execute    : Proxy_Object := Set_Member'Access;
      Get_Member : Get_Member_Access;
   end record;

   type Attribute_Mapping is new Mapping with record
      Index   : Fields;
   end record;
   type Attribute_Mapping_Access is access all Attribute_Mapping'Class;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object);

   type Proxy_Mapper is new Mapper with null record;
   type Proxy_Mapper_Access is access all Proxy_Mapper'Class;

   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String;
                         Attribute  : in Boolean := False)
                         return Util.Serialize.Mappers.Mapper_Access;

end Util.Serialize.Mappers.Record_Mapper;

Allow an indefinite type as Element_Type for the generic package


-----------------------------------------------------------------------
--  Security-oayth-jwt-tests - Unit tests for JSON Web Token
--  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.Tests;

package Security.OAuth.JWT.Tests is

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

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

   --  Test Decode operation with errors.
   procedure Test_Decode_Error (T : in out Test);

   generic
      with function Get (From : in Token) return String;
      Value : String;
   procedure Test_Operation (T : in out Test);

   generic
      with function Get (From : in Token) return Ada.Calendar.Time;
      Value : String;
   procedure Test_Time_Operation (T : in out Test);

end Security.OAuth.JWT.Tests;

Add unit tests for JWT

Add unit tests for JWT


-----------------------------------------------------------------------
--  awa-images-tests -- Unit tests for images module
--  Copyright (C) 2018, 2019, 2020 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.Strings;

with ADO;
with Servlet.Streams;
with ASF.Tests;
with AWA.Tests.Helpers.Users;
with AWA.Images.Beans;
with AWA.Images.Models;
with AWA.Images.Modules;
with AWA.Services.Contexts;
with Security.Contexts;

package body AWA.Images.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Beans.Create",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Servlets (missing)",
                       Test_Missing_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the wiki as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String) is
      pragma Unreferenced (Title);

      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/images.html",
                        "images-anonymous-list.html");
      ASF.Tests.Assert_Contains (T, "List of pages", Reply,
                                 "Wiki list recent page is invalid");
   end Verify_Anonymous;

   --  ------------------------------
   --  Verify that the wiki lists contain the given page.
   --  ------------------------------
   procedure Verify_List_Contains (T    : in out Test;
                                   Name : in String) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/documents.html",
                        "storage-list.html");
      ASF.Tests.Assert_Contains (T, "Documents of the workspace", Reply,
                                 "List of documents is invalid");
   end Verify_List_Contains;

   --  ------------------------------
   --  Test access to the blog as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("", "");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of image by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      AWA.Tests.Helpers.Users.Login ("test-image@test.com", Request);
      Request.Set_Parameter ("folder-name", "Image Folder Name");
      Request.Set_Parameter ("storage-folder-create-form", "1");
      Request.Set_Parameter ("storage-folder-create-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/storages/forms/folder-create.html", "folder-create-form.html");

      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response after folder creation");

      ASF.Tests.Do_Get (Request, Reply, "/storages/images.html",
                        "image-list.html");
      ASF.Tests.Assert_Contains (T, "Documents of the workspace", Reply,
                                 "List of documents is invalid (title)");
      ASF.Tests.Assert_Contains (T, "Test Folder Name", Reply,
                                 "List of documents is invalid (content)");
   end Test_Create_Image;

   --  ------------------------------
   --  Test getting an image which does not exist.
   --  ------------------------------
   procedure Test_Missing_Image (T : in out Test) is
      Request   : Servlet.Requests.Mockup.Request;
      Reply     : Servlet.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/storages/images/12345345/view/missing.jpg",
                        "image-file-missing.html");
      ASF.Tests.Assert_Matches (T, ".title.Page not found./title.", Reply,
                                "Page for a missing document is invalid",
                                Servlet.Responses.SC_NOT_FOUND);
   end Test_Missing_Image;

end AWA.Images.Tests;

Implement the tests for the image service by simulating web requests


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . G N A T _ I N T                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2008, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains the utility routines used for calling the GNAT
--  compiler from inside the ASIS implementation routines to create a tree
--  file.  These routines may be used by ASIS-based tools as well. The idea is
--  to call GNAT in a black-box manner. The current version of this package
--  borrows most of the ideas and the code patterns from the body of the
--  GNAT Make package (which defines the gnatmake-related routines).
--  Unfortunately, GNAT do not provide the public interface to these
--  routines, so we simply have copied the code from make.adb with some
--  modifications.
--
--  This package also contains the routine which reads the tree file with
--  checking the GNAT-ASIS versions compartibility.

with Ada.Calendar; use Ada.Calendar;

with A4G.A_Types;  use A4G.A_Types;
with A4G.A_Debug;

with GNAT.OS_Lib;  use GNAT.OS_Lib;
with Types;        use Types;

package A4G.GNAT_Int is

   -----------------------------------
   -- Compiler Variables & Routines --
   -----------------------------------

   Nul_Argument_List : constant Argument_List (1 .. 0) := (others => null);

   --  The flags listed below are used to form the appropriate GNAT or
   --  gnatmake call to create the tree file

   Comp_Flag    : constant String_Access := new String'("-c");

   GNAT_Flag    : constant String_Access := new String'("-gnatg");
   GNAT_Flag_ct : constant String_Access := new String'("-gnatct");
   GNAT_Flag_t  : constant String_Access := new String'("-gnatt");
   GNAT_Flag_ws : constant String_Access := new String'("-gnatws");
   GNAT_Flag_yN : constant String_Access := new String'("-gnatyN");
   GNAT_Flag_05 : constant String_Access := new String'("-gnat05");

   GCC_Flag_X   : constant String_Access := new String'("-x");
   GCC_Par_Ada  : constant String_Access := new String'("ada");
   GCC_Flag_o   : constant String_Access := new String'("-o");

   GNATMAKE_Flag_q     : constant String_Access := new String'("-q");
   GNATMAKE_Flag_u     : constant String_Access := new String'("-u");
   GNATMAKE_Flag_f     : constant String_Access := new String'("-f");
   GNATMAKE_Flag_cargs : constant String_Access := new String'("-cargs");

--   Display_Executed_Programs : Boolean renames A4G.A_Debug.Debug_Mode;
   --  Set to True if name of commands should be output on stderr.
   --  Now this flag is toughtly binded with the flag setting the
   --  ASIS Debug Mode. Is it a good decision?

   function Execute
     (Program      : String_Access;
      Args         : Argument_List;
      Compiler_Out : String := "";
      Display_Call : Boolean := A4G.A_Debug.Debug_Mode)
      return         Boolean;
   --  Executes Program. If the program is not set (the actual for Program is
   --  null), executes the gcc command Args contains the arguments to be passed
   --  to Program. If the program is executed successfully True is returned.
   --
   --  If Compiler_Out is a non-empty string, this string is treated as the
   --  name of a text file to redirect the compiler output into (if the file
   --  does not exist, it is created). Othervise the compiler output is
   --  sent to Stderr.
   --
   --  If Display_Call is ON, outputs into Stderr the command used to execure
   --  Program.

   procedure Create_Tree (Source_File   :     String_Access;
                          Context       :     Context_Id;
                          Is_Predefined :     Boolean;
                          Success       : out Boolean);
   --  Tries to create the tree output file for the given source file
   --  in the context of a given Context. Uses the "standard" GNAT
   --  installation to do this

   procedure Tree_In_With_Version_Check
     (Desc    : File_Descriptor;
      Cont    : Context_Id;
      Success : out Boolean);
   --  Desc is the file descriptor for the file containing the tree file
   --  created by the compiler, Cont is the Id of the Context this tree is
   --  supposed to belong to. This routine reads in the content of the tree
   --  file and makes the GNAT-ASIS version check as a part of tree reading.
   --  If the version check fails or if any error corresponding to the problems
   --  with the expected tree format is detected, Program_Error is raised with
   --  the exception message "Inconsistent versions of GNAT and ASIS". If
   --  the tree can not be read in because of any other reason (for example,
   --  it is not compile-only), the Success parameter is set OFF and the
   --  continuation depends on the Context parameters. If the tree has been
   --  read in successfully and if it is compile-only, Success is set ON.
   --
   --  Before calling this procedure, a caller should put the name of the tree
   --  file to read into A_Name_Buffer.
   --
   --  NOTE: the procedure always closes Desc before returning. Closing it
   --  the second time is erroneous.

   function A_Time (T : Time_Stamp_Type)
      return Time;
   --  Converts GNAT file time stamp into the corresponding value
   --  of Asis_Time.

end A4G.GNAT_Int;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Tests;

package Util.Streams.Buffered.Lzma.Tests is

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

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

   procedure Test_Compress_Stream (T : in out Test);

end Util.Streams.Buffered.Lzma.Tests;

Add a new test for Compress_Stream using LZMA


-----------------------------------------------------------------------
--  Util.Beans.Objects.Datasets -- Datasets
--  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.Unchecked_Deallocation;

package body Util.Beans.Objects.Datasets is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Object_Array,
                                      Name   => Object_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Dataset_Array,
                                     Name   => Dataset_Array_Access);

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Dataset) return Natural is
   begin
      return From.Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Dataset;
                            Index : in Natural) is
   begin
      From.Current_Pos  := Index;
      From.Current.Data := From.Data (Index);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Dataset) 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.
   --  ------------------------------
   overriding
   function Get_Value (From : in Dataset;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Current_Pos);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Append a row in the dataset and call the fill procedure to populate
   --  the row content.
   --  ------------------------------
   procedure Append (Into : in out Dataset;
                     Fill : not null access procedure (Data : in out Object_Array)) is
      Data : constant Object_Array_Access := new Object_Array (1 .. Into.Columns);
   begin
      if Into.Data = null then
         Into.Data := new Dataset_Array (1 .. 10);
      elsif Into.Count >= Into.Data'Last then
         declare
            --  Sun's Java ArrayList use a 2/3 grow factor.
            --  Python's array use 8/9.
            Grow : constant Positive := (Into.Count * 2) / 3;
            Set  : constant Dataset_Array_Access := new Dataset_Array (1 .. Grow);
         begin
            Set (Into.Data'Range) := Into.Data.all;
            Free (Into.Data);
            Into.Data := Set;
         end;
      end if;
      Into.Count := Into.Count + 1;
      Into.Data (Into.Count) := Data;
      Fill (Data.all);
   end Append;

   --  ------------------------------
   --  Add a column to the dataset.  If the position is not specified,
   --  the column count is incremented and the name associated with the last column.
   --  Raises Invalid_State exception if the dataset contains some rows,
   --  ------------------------------
   procedure Add_Column (Into : in out Dataset;
                         Name : in String;
                         Pos  : in Natural := 0) is
      Col : Positive;
   begin
      if Into.Count /= 0 then
         raise Invalid_State with "The dataset contains some rows.";
      end if;
      if Pos = 0 then
         Col := Into.Columns + 1;
      else
         Col := Pos;
      end if;
      Into.Map.Insert (Name, Col);
      if Into.Columns < Col then
         Into.Columns := Col;
      end if;
   end Add_Column;

   --  ------------------------------
   --  Clear the content of the dataset.
   --  ------------------------------
   procedure Clear (Set : in out Dataset) is
   begin
      for I in 1 .. Set.Count loop
         Free (Set.Data (I));
      end loop;
      Set.Count        := 0;
      Set.Current_Pos  := 0;
      Set.Current.Data := null;
   end Clear;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Row;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         return From.Data (Dataset_Map.Element (Pos));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Row;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         From.Data (Dataset_Map.Element (Pos)) := Value;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Set : in out Dataset) is
   begin
      Set.Row := To_Object (Value   => Set.Current'Unchecked_Access,
                            Storage => STATIC);
      Set.Current.Map := Set.Map'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Release the dataset storage.
   --  ------------------------------
   overriding
   procedure Finalize (Set : in out Dataset) is
   begin
      Set.Clear;
      Free (Set.Data);
   end Finalize;

end Util.Beans.Objects.Datasets;

Implement the Datasets package

Implement the Datasets package


-----------------------------------------------------------------------
--  util-events-timers -- Timer list 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 Util.Events.Timers is

   use type Ada.Real_Time.Time;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Timer_Node,
                                     Name   => Timer_Node_Access);

   --  Repeat the timer.
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span) is
   begin
      null;
   end Repeat;

   --  -----------------------
   --  Cancel the timer.
   --  -----------------------
   procedure Cancel (Event : in out Timer_Ref) is
   begin
      if Event.Value /= null and then Event.Value.List /= null then
         Event.Value.List.all.Cancel (Event.Value);
         Event.Value.List := null;
      end if;
   end Cancel;

   --  -----------------------
   --  Check if the timer is ready to be executed.
   --  -----------------------
   function Is_Scheduled (Event : in Timer_Ref) return Boolean is
   begin
      return Event.Value /= null and then Event.Value.List /= null;
   end Is_Scheduled;

   --  -----------------------
   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   --  -----------------------
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time is
   begin
      return (if Event.Value /= null then Event.Value.Deadline else Ada.Real_Time.Time_Last);
   end Time_Of_Event;

   --  -----------------------
   --  Set a timer to be called at the given time.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time) is
   begin
      if Event.Value = null then
         Event.Value := new Timer_Node;
      end if;
      Event.Value.Handler := Handler;

      --  Cancel the timer if it is part of another timer manager.
      if Event.Value.List /= null and Event.Value.List /= List.Manager'Unchecked_Access then
         Event.Value.List.all.Cancel (Event.Value);
      end if;

      --  Update the timer.
      Event.Value.List := List.Manager'Unchecked_Access;
      List.Manager.Add (Event.Value, At_Time);
   end Set_Timer;

   --  -----------------------
   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   --  -----------------------
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last) is
      Timer : Timer_Ref;
   begin
      loop
         List.Manager.Find_Next (Timeout, Timer);
         exit when not Timer.Is_Scheduled;
         Timer.Value.Handler.Time_Handler (Timer);
      end loop;
   end Process;

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

   overriding
   procedure Finalize (Object : in out Timer_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Decrement (Object.Value.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Value);
         else
            Object.Value := null;
         end if;
      end if;
   end Finalize;

   protected body Timer_Manager is

      --  -----------------------
      --  Add a timer.
      --  -----------------------
      procedure Add (Timer    : in out Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time) is
         Current : Timer_Node_Access := List;
         Prev    : Timer_Node_Access;
      begin
         Util.Concurrent.Counters.Increment (Timer.Counter);
         if Timer.List /= null then
            Cancel (Timer);
         end if;
         Timer.Deadline := Deadline;
         while Current /= null loop
            if Current.Deadline < Deadline then
               if Prev = null then
                  List := Timer;
               else
                  Prev.Next := Timer;
               end if;
               Timer.Next := Current;
               Current.Prev := Timer;
               return;
            end if;
            Prev := Current;
            Current := Current.Next;
         end loop;
         if Prev = null then
            List := Timer;
            Timer.Prev := null;
         else
            Prev.Next := Timer;
            Timer.Prev := Prev;
         end if;
         Timer.Next := null;
      end Add;

      --  -----------------------
      --  Cancel a timer.
      --  -----------------------
      procedure Cancel (Timer : in out Timer_Node_Access) is
         Is_Zero : Boolean;
      begin
         if Timer.List = null then
            return;
         end if;
         if List = Timer then
            List := Timer.Next;
            Timer.Prev := null;
            if List /= null then
               List.Prev := null;
            end if;
         elsif Timer.Prev /= null then
            Timer.Prev.Next := Timer.Next;
            Timer.Next.Prev := Timer.Prev;
         else
            return;
         end if;
         Timer.Next := null;
         Timer.Prev := null;
         Timer.List := null;
         Util.Concurrent.Counters.Decrement (Timer.Counter, Is_Zero);
         if Is_Zero then
            Free (Timer);
         end if;
      end Cancel;

      --  -----------------------
      --  Find the next timer to be executed or return the next deadline.
      --  -----------------------
      procedure Find_Next (Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref) is
         Now : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
      begin
         if List = null then
            Timer.Finalize;
            Deadline := Ada.Real_Time.Time_Last;
         elsif List.Deadline < Now then
            Timer.Value := List;
            Util.Concurrent.Counters.Increment (Timer.Value.Counter);
            List := List.Next;
            if List /= null then
               List.Prev := null;
               Deadline := List.Deadline;
            else
               Deadline := Ada.Real_Time.Time_Last;
            end if;
         else
            Deadline := List.Deadline;
            Timer.Finalize;
         end if;
      end Find_Next;

   end Timer_Manager;

   overriding
   procedure Finalize (Object : in out Timer_List) is
   begin
      null;
   end Finalize;

end Util.Events.Timers;

Implement the timer management operations


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

with Util.Tests;

with ASF.Contexts.Faces.Tests;
package ASF.Converters.Tests is

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

   type Test is new ASF.Contexts.Faces.Tests.Test with null record;

   --  Test the date short converter.
   procedure Test_Date_Short_Converter (T : in out Test);

   --  Test the date medium converter.
   procedure Test_Date_Medium_Converter (T : in out Test);

   --  Test the date long converter.
   procedure Test_Date_Long_Converter (T : in out Test);

   --  Test the date full converter.
   procedure Test_Date_Full_Converter (T : in out Test);

   --  Test the time short converter.
   procedure Test_Time_Short_Converter (T : in out Test);

   --  Test the time short converter.
   procedure Test_Time_Medium_Converter (T : in out Test);

   --  Test the time long converter.
   procedure Test_Time_Long_Converter (T : in out Test);

end ASF.Converters.Tests;

Add a new set of unit tests for the date converter


with Interfaces; use Interfaces;

package HAL.Block_Drivers is

   type Block_Driver is limited interface;
   type Block_Driver_Ref is access all Block_Driver'Class;

   subtype Block is Byte_Array;

   function Read
     (This         : in out Block_Driver;
      Block_Number : Unsigned_32;
      Data         : out Block)
      return Boolean is abstract;

   function Write
     (This         : in out Block_Driver;
      Block_Number : Unsigned_32;
      Data         : Block)
      return Boolean is abstract;

end HAL.Block_Drivers;

Add block driver interface

HAL: Add block driver interface