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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Add tests for the Is_Primary function

Add tests for the Is_Primary function


-----------------------------------------------------------------------
--  wiki-streams-text_io -- Text_IO input output streams
--  Copyright (C) 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 Ada.Wide_Wide_Text_IO;

--  === Text_IO Input and Output streams ===
--  The <tt>Wiki.Streams.Text_IO</tt> package defines the <tt>File_Input_Stream</tt> and
--  the <tt>File_Output_Stream</tt/ types which use the <tt>Ada.Wide_Wide_Text_IO</tt> package
--  to read or write the output streams.
--
--  By default the <tt>File_Input_Stream</tt> is configured to read the standard input.
--  The <tt>Open</tt> procedure can be used to read from a file knowing its name.
--
--  The <tt>File_Output_Stream</tt> is configured to write on the standard output.
--  The <tt>Open</tt> and <tt>Create</tt> procedure can be used to write on a file.
--
package Wiki.Streams.Text_IO is

   type File_Input_Stream is limited new Wiki.Streams.Input_Stream with private;
   type File_Input_Stream_Access is access all File_Input_Stream'Class;

   --  Open the file and prepare to read the input stream.
   procedure Open (Stream : in out File_Input_Stream;
                   Path   : in String;
                   Form   : in String := "");

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

   type File_Output_Stream is limited new Wiki.Streams.Output_Stream with private;
   type File_Output_Stream_Access is access all File_Output_Stream'Class;

   --  Open the file and prepare to write the output stream.
   procedure Open (Stream : in out File_Output_Stream;
                   Path   : in String;
                   Form   : in String := "");

   --  Create the file and prepare to write the output stream.
   procedure Create (Stream : in out File_Output_Stream;
                     Path   : in String;
                     Form   : in String := "");

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

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

private

   type File_Input_Stream is limited new Wiki.Streams.Input_Stream with record
      File : Ada.Wide_Wide_Text_IO.File_Type;
   end record;

   type File_Output_Stream is limited new Wiki.Streams.Output_Stream with record
      File : Ada.Wide_Wide_Text_IO.File_Type := Ada.Wide_Wide_Text_IO.Current_Output;
   end record;

end Wiki.Streams.Text_IO;

-----------------------------------------------------------------------
--  wiki-streams-text_io -- Text_IO input output streams
--  Copyright (C) 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 Ada.Wide_Wide_Text_IO;

--  === Text_IO Input and Output streams ===
--  The <tt>Wiki.Streams.Text_IO</tt> package defines the <tt>File_Input_Stream</tt> and
--  the <tt>File_Output_Stream</tt/ types which use the <tt>Ada.Wide_Wide_Text_IO</tt> package
--  to read or write the output streams.
--
--  By default the <tt>File_Input_Stream</tt> is configured to read the standard input.
--  The <tt>Open</tt> procedure can be used to read from a file knowing its name.
--
--  The <tt>File_Output_Stream</tt> is configured to write on the standard output.
--  The <tt>Open</tt> and <tt>Create</tt> procedure can be used to write on a file.
--
package Wiki.Streams.Text_IO is

   type File_Input_Stream is limited new Wiki.Streams.Input_Stream with private;
   type File_Input_Stream_Access is access all File_Input_Stream'Class;

   --  Open the file and prepare to read the input stream.
   procedure Open (Stream : in out File_Input_Stream;
                   Path   : in String;
                   Form   : in String := "");

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

   type File_Output_Stream is limited new Wiki.Streams.Output_Stream with private;
   type File_Output_Stream_Access is access all File_Output_Stream'Class;

   --  Open the file and prepare to write the output stream.
   procedure Open (Stream : in out File_Output_Stream;
                   Path   : in String;
                   Form   : in String := "");

   --  Close the file.
   procedure Close (Stream : in out File_Input_Stream);

   --  Create the file and prepare to write the output stream.
   procedure Create (Stream : in out File_Output_Stream;
                     Path   : in String;
                     Form   : in String := "");

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

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

private

   type File_Input_Stream is limited new Wiki.Streams.Input_Stream with record
      File : Ada.Wide_Wide_Text_IO.File_Type;
   end record;

   type File_Output_Stream is limited new Wiki.Streams.Output_Stream with record
      File : Ada.Wide_Wide_Text_IO.File_Type := Ada.Wide_Wide_Text_IO.Current_Output;
   end record;

end Wiki.Streams.Text_IO;

Declare the Close procedure

Declare the Close procedure


-----------------------------------------------------------------------
--  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 Ada.Directories;
with Util.Test_Caller;
with Util.Strings;

with ADO;
with Servlet.Requests.Mockup;
with Servlet.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Images.Tests is

   use Ada.Strings.Unbounded;
   use ADO;

   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.Part_Request (1);
      Reply     : Servlet.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
      Folder_Id : ADO.Identifier;
      Image_Id  : ADO.Identifier;
      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/result/upload.jpg");
   begin
      AWA.Tests.Helpers.Users.Login ("test-image@test.com", Request);

      --  Create the folder.
      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");

      Reply.Read_Content (Content);
      Folder_Id := AWA.Tests.Helpers.Extract_Identifier (To_String (Content), "#folder");
      T.Assert (Folder_Id > 0, "Invalid folder id returned");

      --  Check the list page.
      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, "Image Folder Name", Reply,
                                 "List of documents is invalid (content)");

      --  Upload an image to the folder.
      if Ada.Directories.Exists (Path) then
         Ada.Directories.Delete_File (Path);
      end if;
      Ada.Directories.Copy_File (Source_Name => "regtests/files/images/Ada-Lovelace.jpg",
                                 Target_Name => Path,
                                 Form        => "all");

      Request.Set_Parameter ("folder", ADO.Identifier'Image (Folder_Id));
      Request.Set_Parameter ("uploadForm", "1");
      Request.Set_Parameter ("id", "-1");
      Request.Set_Parameter ("upload-button", "1");
      Request.Set_Part (Position => 1, Name => "upload-file",
                        Path => Path, Content_Type => "image/jpg");
      ASF.Tests.Do_Post (Request, Reply, "/storages/forms/upload-form.html",
                         "upload-image-form.html");

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

      T.Assert_Equals ("application/json", Reply.Get_Content_Type,
                       "Invalid response after upload");

      Reply.Read_Content (Content);
      Image_Id := AWA.Tests.Helpers.Extract_Identifier (To_String (Content), "store");
      T.Assert (Image_Id > 0, "Invalid image id returned after upload");

      --  Look at the image content.
      ASF.Tests.Do_Get (Request, Reply, "/storages/images/"
                          & Util.Strings.Image (Natural (Image_Id)) & "/view/upload.jpg",
                        "image-file-data.jpg");
      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response after image get");
      T.Assert_Equals ("image/jpg", Reply.Get_Content_Type,
                       "Invalid response after upload");

      --  Look at the image description page.
      ASF.Tests.Do_Get (Request, Reply, "/storages/image-info/"
                          & Util.Strings.Image (Natural (Image_Id)),
                        "image-file-info.html");
      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response for image-info page");
      T.Assert_Equals ("text/html; charset=UTF-8", Reply.Get_Content_Type,
                       "Invalid response for image-info");
      ASF.Tests.Assert_Contains (T, "/storages/files/"
                                   & Util.Strings.Image (Natural (Image_Id)) & "/", Reply,
                                 "Image info page is invalid (missing link)");

   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;

-----------------------------------------------------------------------
--  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 Ada.Directories;
with Util.Test_Caller;
with Util.Strings;

with ADO;
with Servlet.Requests.Mockup;
with Servlet.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Images.Tests is

   use Ada.Strings.Unbounded;
   use ADO;

   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.Part_Request (1);
      Reply     : Servlet.Responses.Mockup.Response;
      Content   : Ada.Strings.Unbounded.Unbounded_String;
      Folder_Id : ADO.Identifier;
      Image_Id  : ADO.Identifier;
      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/result/upload.jpg");
   begin
      AWA.Tests.Helpers.Users.Login ("test-image@test.com", Request);

      --  Create the folder.
      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");

      Reply.Read_Content (Content);
      Folder_Id := AWA.Tests.Helpers.Extract_Identifier (To_String (Content), "#folder");
      T.Assert (Folder_Id > 0, "Invalid folder id returned");

      --  Check the list page.
      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, "Image Folder Name", Reply,
                                 "List of documents is invalid (content)");

      --  Upload an image to the folder.
      if Ada.Directories.Exists (Path) then
         Ada.Directories.Delete_File (Path);
      end if;
      Ada.Directories.Copy_File (Source_Name => "regtests/files/images/Ada-Lovelace.jpg",
                                 Target_Name => Path,
                                 Form        => "all");

      Request.Set_Parameter ("folder", ADO.Identifier'Image (Folder_Id));
      Request.Set_Parameter ("uploadForm", "1");
      Request.Set_Parameter ("id", "-1");
      Request.Set_Parameter ("upload-button", "1");
      Request.Set_Part (Position => 1, Name => "upload-file",
                        Path => Path, Content_Type => "image/jpg");
      ASF.Tests.Do_Post (Request, Reply, "/storages/forms/upload-form.html",
                         "upload-image-form.html");

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

      T.Assert_Equals ("application/json", Reply.Get_Content_Type,
                       "Invalid response after upload");

      Reply.Read_Content (Content);
      Image_Id := AWA.Tests.Helpers.Extract_Identifier (To_String (Content), "store");
      T.Assert (Image_Id > 0, "Invalid image id returned after upload");

      --  Look at the image content.
      ASF.Tests.Do_Get (Request, Reply, "/storages/images/"
                          & Util.Strings.Image (Natural (Image_Id)) & "/view/upload.jpg",
                        "image-file-data.jpg");
      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response after image get");
      T.Assert_Equals ("image/jpg", Reply.Get_Content_Type,
                       "Invalid response after upload");

      --  Look at the image description page.
      ASF.Tests.Do_Get (Request, Reply, "/storages/image-info/"
                          & Util.Strings.Image (Natural (Image_Id)),
                        "image-file-info.html");
      T.Assert (Reply.Get_Status = Servlet.Responses.SC_OK,
                "Invalid response for image-info page");
      T.Assert_Equals ("text/html; charset=UTF-8", Reply.Get_Content_Type,
                       "Invalid response for image-info");
      ASF.Tests.Assert_Contains (T, "/storages/files/"
                                   & Util.Strings.Image (Natural (Image_Id)) & "/", Reply,
                                 "Image info page is invalid (missing link)");

   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_Redirect (T, "/auth/login.html", Reply,
                                "Invalid redirection for protected page");

      AWA.Tests.Helpers.Users.Login ("test-image@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/storages/images/12345345/view/missing.jpg",
                        "image-file-missing.html");
      T.Assert (Reply.Get_Status = Servlet.Responses.SC_NOT_FOUND,
                "Invalid response after image get");
   end Test_Missing_Image;

end AWA.Images.Tests;

Fix the Test_Missing_Image unit test

Fix the Test_Missing_Image unit test


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

with ASF.Lifecycles.Restore;
with ASF.Lifecycles.Apply;
with ASF.Lifecycles.Validation;
with ASF.Lifecycles.Update;
with ASF.Lifecycles.Invoke;
with ASF.Lifecycles.Response;
package body ASF.Lifecycles.Default is

   --  ------------------------------
   --  Creates the phase controllers by invoking the Set_Controller
   --  procedure for each phase.  This is called by Initialize to build
   --  the lifecycle handler.
   --  ------------------------------
   procedure Create_Phase_Controllers (Controller : in out Lifecycle) is
      use ASF.Events.Phases;
   begin
      Controller.Set_Controller (Phase    => RESTORE_VIEW,
                                 Instance => new Lifecycles.Restore.Restore_Controller);

      Controller.Set_Controller (Phase    => APPLY_REQUEST_VALUES,
                                 Instance => new Lifecycles.Apply.Apply_Controller);

      Controller.Set_Controller (Phase    => PROCESS_VALIDATION,
                                 Instance => new Lifecycles.Validation.Validation_Controller);

      Controller.Set_Controller (Phase    => UPDATE_MODEL_VALUES,
                                 Instance => new Lifecycles.Update.Update_Controller);

      Controller.Set_Controller (Phase    => INVOKE_APPLICATION,
                                 Instance => new Lifecycles.Invoke.Invoke_Controller);

      Controller.Set_Controller (Phase    => RENDER_RESPONSE,
                                 Instance => new Lifecycles.Response.Response_Controller);
   end Create_Phase_Controllers;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      Lifecycle'Class (Controller).Create_Phase_Controllers;
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

end ASF.Lifecycles.Default;

-----------------------------------------------------------------------
--  asf-lifecycles-default -- Default Lifecycle handler
--  Copyright (C) 2010, 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 ASF.Lifecycles.Restore;
with ASF.Lifecycles.Apply;
with ASF.Lifecycles.Validation;
with ASF.Lifecycles.Update;
with ASF.Lifecycles.Invoke;
with ASF.Lifecycles.Response;
package body ASF.Lifecycles.Default is

   --  ------------------------------
   --  Creates the phase controllers by invoking the Set_Controller
   --  procedure for each phase.  This is called by Initialize to build
   --  the lifecycle handler.
   --  ------------------------------
   procedure Create_Phase_Controllers (Controller : in out Lifecycle) is
      use ASF.Events.Phases;
   begin
      Controller.Set_Controller (Phase    => RESTORE_VIEW,
                                 Instance => new Lifecycles.Restore.Restore_Controller);

      Controller.Set_Controller (Phase    => APPLY_REQUEST_VALUES,
                                 Instance => new Lifecycles.Apply.Apply_Controller);

      Controller.Set_Controller (Phase    => PROCESS_VALIDATION,
                                 Instance => new Lifecycles.Validation.Validation_Controller);

      Controller.Set_Controller (Phase    => UPDATE_MODEL_VALUES,
                                 Instance => new Lifecycles.Update.Update_Controller);

      Controller.Set_Controller (Phase    => INVOKE_APPLICATION,
                                 Instance => new Lifecycles.Invoke.Invoke_Controller);

      Controller.Set_Controller (Phase    => RENDER_RESPONSE,
                                 Instance => new Lifecycles.Response.Response_Controller);
   end Create_Phase_Controllers;

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Lifecycle;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Lifecycle'Class (Controller).Create_Phase_Controllers;
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (Views);
      end loop;
   end Initialize;

end ASF.Lifecycles.Default;

Update Initialize to use a ASF.Applications.Views.View_Handler'Class


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

with AWA.Modules.Get;
with AWA.Modules.Beans;
with AWA.Applications;
with AWA.Storages.Beans.Factories;

package body AWA.Storages.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Storages.Module");

   package Register is new AWA.Modules.Beans (Module        => Storage_Module,
                                              Module_Access => Storage_Module_Access);

   --  ------------------------------
   --  Initialize the storage module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Storage_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the storage module");

      --  Setup the resource bundles.
      App.Register ("storageMsg", "storages");

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Upload_Bean",
                         Handler => AWA.Storages.Beans.Create_Upload_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Folder_Bean",
                         Handler => AWA.Storages.Beans.Factories.Create_Folder_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Folder_List_Bean",
                         Handler => AWA.Storages.Beans.Create_Folder_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Storage_List_Bean",
                         Handler => AWA.Storages.Beans.Create_Storage_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Storage_Bean",
                         Handler => AWA.Storages.Beans.Create_Storage_Bean'Access);

      App.Add_Servlet ("storage", Plugin.Storage_Servlet'Unchecked_Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Create the storage manager when everything is initialized.
      Plugin.Manager := Plugin.Create_Storage_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the storage manager.
   --  ------------------------------
   function Get_Storage_Manager (Plugin : in Storage_Module)
                                 return Services.Storage_Service_Access is
   begin
      return Plugin.Manager;
   end Get_Storage_Manager;

   --  ------------------------------
   --  Create a storage manager.  This operation can be overriden to provide another
   --  storage service implementation.
   --  ------------------------------
   function Create_Storage_Manager (Plugin : in Storage_Module)
                                    return Services.Storage_Service_Access is
      Result : constant Services.Storage_Service_Access := new Services.Storage_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_Storage_Manager;

   --  ------------------------------
   --  Get the storage module instance associated with the current application.
   --  ------------------------------
   function Get_Storage_Module return Storage_Module_Access is
      function Get is new AWA.Modules.Get (Storage_Module, Storage_Module_Access, NAME);
   begin
      return Get;
   end Get_Storage_Module;

   --  ------------------------------
   --  Get the storage manager instance associated with the current application.
   --  ------------------------------
   function Get_Storage_Manager return Services.Storage_Service_Access is
      Module : constant Storage_Module_Access := Get_Storage_Module;
   begin
      if Module = null then
         Log.Error ("There is no active Storage_Module");
         return null;
      else
         return Module.Get_Storage_Manager;
      end if;
   end Get_Storage_Manager;

end AWA.Storages.Modules;

-----------------------------------------------------------------------
--  awa-storages-module -- Storage management module
--  Copyright (C) 2012, 2016, 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.Log.Loggers;

with AWA.Modules.Get;
with AWA.Modules.Beans;
with AWA.Applications;
with AWA.Storages.Beans.Factories;

package body AWA.Storages.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Storages.Module");

   package Register is new AWA.Modules.Beans (Module        => Storage_Module,
                                              Module_Access => Storage_Module_Access);

   --  ------------------------------
   --  Initialize the storage module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Storage_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the storage module");

      --  Setup the resource bundles.
      App.Register ("storageMsg", "storages");

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Upload_Bean",
                         Handler => AWA.Storages.Beans.Create_Upload_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Folder_Bean",
                         Handler => AWA.Storages.Beans.Factories.Create_Folder_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Folder_List_Bean",
                         Handler => AWA.Storages.Beans.Create_Folder_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Storage_List_Bean",
                         Handler => AWA.Storages.Beans.Create_Storage_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Storages.Beans.Storage_Bean",
                         Handler => AWA.Storages.Beans.Create_Storage_Bean'Access);

      App.Add_Servlet ("storage", Plugin.Storage_Servlet'Unchecked_Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Storage_Module;
                        Props  : in ASF.Applications.Config) is
   begin
      --  Create the storage manager when everything is initialized.
      Plugin.Manager := Plugin.Create_Storage_Manager;
   end Configure;

   --  ------------------------------
   --  Get the storage manager.
   --  ------------------------------
   function Get_Storage_Manager (Plugin : in Storage_Module)
                                 return Services.Storage_Service_Access is
   begin
      return Plugin.Manager;
   end Get_Storage_Manager;

   --  ------------------------------
   --  Create a storage manager.  This operation can be overriden to provide another
   --  storage service implementation.
   --  ------------------------------
   function Create_Storage_Manager (Plugin : in Storage_Module)
                                    return Services.Storage_Service_Access is
      Result : constant Services.Storage_Service_Access := new Services.Storage_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_Storage_Manager;

   --  ------------------------------
   --  Get the storage module instance associated with the current application.
   --  ------------------------------
   function Get_Storage_Module return Storage_Module_Access is
      function Get is new AWA.Modules.Get (Storage_Module, Storage_Module_Access, NAME);
   begin
      return Get;
   end Get_Storage_Module;

   --  ------------------------------
   --  Get the storage manager instance associated with the current application.
   --  ------------------------------
   function Get_Storage_Manager return Services.Storage_Service_Access is
      Module : constant Storage_Module_Access := Get_Storage_Module;
   begin
      if Module = null then
         Log.Error ("There is no active Storage_Module");
         return null;
      else
         return Module.Get_Storage_Manager;
      end if;
   end Get_Storage_Manager;

end AWA.Storages.Modules;

Add Configure procedure to allow the configuration of the storage service


-----------------------------------------------------------------------
--  mat-readers -- Reader
--  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.Log.Loggers;

with MAT.Readers.Marshaller;
with Interfaces;
package body MAT.Events.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Events.Probes");

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message_Type);

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
      Manager.Frames := MAT.Frames.Create_Root;
   end Initialize;

   --  ------------------------------
   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   --  ------------------------------
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                              Probe  : in Probe_Type_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Targets.Probe_Index_Type;
                              Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      use type Interfaces.Unsigned_64;

      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop
                     if Count < Frame.Depth then
                        Frame.Frame (I) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      Client.Event.Time := Interfaces.Shift_Left (Interfaces.Unsigned_64 (Time_Sec), 32);
      Client.Event.Time := Client.Event.Time or Interfaces.Unsigned_64 (Time_Usec);
      Frame.Cur_Depth := Count;
   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            MAT.Frames.Insert (Frame  => Client.Frames,
                               Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                               Result => Client.Event.Frame);
            Client.Events.Insert (Client.Event);
            Handler.Probe.Execute (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  Read a list of event definitions from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

   --  ------------------------------
   --  Read the event data stream headers with the event description.
   --  Configure the reader to analyze the data stream according to the event descriptions.
   --  ------------------------------
   procedure Read_Headers (Client : in out Probe_Manager_Type;
                           Msg    : in out MAT.Readers.Message_Type) is
   begin
      Client.Read_Event_Definitions (Msg);

      Client.Frame := new MAT.Events.Frame_Info (512);
   exception
         when E : others =>
         Log.Error ("Exception while reading headers ", E);
   end Read_Headers;

end MAT.Events.Probes;

-----------------------------------------------------------------------
--  mat-readers -- Reader
--  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.Log.Loggers;

with MAT.Readers.Marshaller;
with Interfaces;
package body MAT.Events.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Events.Probes");

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message_Type);

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type is
   begin
      return Ada.Containers.Hash_Type (Key);
   end Hash;

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
      Manager.Frames := MAT.Frames.Create_Root;
   end Initialize;

   --  ------------------------------
   --  Register the probe to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   --  ------------------------------
   procedure Register_Probe (Into   : in out Probe_Manager_Type;
                              Probe  : in Probe_Type_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Targets.Probe_Index_Type;
                              Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop
                     if Count < Frame.Depth then
                        Frame.Frame (I) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      Client.Event.Time := Interfaces.Shift_Left (Interfaces.Unsigned_64 (Time_Sec), 32);
      Client.Event.Time := Client.Event.Time or Interfaces.Unsigned_64 (Time_Usec);
      Frame.Cur_Depth := Count;
   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            MAT.Frames.Insert (Frame  => Client.Frames,
                               Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                               Result => Client.Event.Frame);
            Client.Events.Insert (Client.Event);
            Handler.Probe.Execute (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  Read a list of event definitions from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

end MAT.Events.Probes;

Remove the Read_Headers procedure

Remove the Read_Headers procedure