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

with Ada.Strings.Fixed;
with Ada.Directories;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with Util.Log;
with Util.Log.Loggers;
with Util.Files;
with Util.Properties;
with Util.Measures;
package body Util.Log.Tests is

   Log : constant Loggers.Logger := Loggers.Create ("util.log.test");

   procedure Test_Log (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      L.Set_Level (DEBUG_LEVEL);
      Log.Info ("My log message");
      Log.Error ("My error message");
      Log.Debug ("A debug message Not printed");

      L.Info ("An info message");
      L.Info ("A {0} {1} {2} {3}", "info", "message", "not", "printed");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Log;

   procedure Test_Debug (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
      C : Ada.Strings.Unbounded.Unbounded_String;
   begin
      L.Set_Level (DEBUG_LEVEL);
      L.Info ("My log message");
      L.Error ("My error message");
      L.Debug ("A {0} {1} {2} {3}", "debug", "message", "not", "printed");
      L.Debug ("A {0} {1} {2} {3}", C, "message", "printed");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Debug;

   --  Test configuration and creation of file
   procedure Test_File_Appender (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_File_Appender;

   procedure Test_Log_Perf (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test_perf.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.perf", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      for I in 1 .. 1000 loop
         declare
            S : Util.Measures.Stamp;
         begin
            Util.Measures.Report (S, "Util.Measures.Report", 1000);
         end;
      end loop;

      declare
         L : Loggers.Logger := Loggers.Create ("util.log.test.perf");
         S : Util.Measures.Stamp;
      begin
         L.Set_Level (DEBUG_LEVEL);
         for I in 1 .. 1000 loop
            L.Info ("My log message: {0}: {1}", "A message",
                    "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Info message (output)", 1000);

         L.Set_Level (INFO_LEVEL);
         for I in 1 .. 10_000 loop
            L.Debug ("My log message: {0}: {1}", "A message",
                     "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Debug message (no output)", 10_000);
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_Log_Perf;

   --  ------------------------------
   --  Test appending the log on several log files
   --  ------------------------------
   procedure Test_List_Appender (T : in out Test) is
      use Ada.Strings;
      use Ada.Directories;
      Props : Util.Properties.Manager;
   begin
      for I in 1 .. 10 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
            Name : constant String := "log4j.appender.test" & Id;
         begin
            Props.Set (Name, "File");
            Props.Set (Name & ".File", Path);
            Props.Set (Name & ".layout", "date-level-message");
            if I > 5 then
               Props.Set (Name & ".level", "INFO");
            end if;
         end;
      end loop;
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Props.Set ("log4j.logger.util.log.test.file",
                 "DEBUG,test4,test1 , test2,test3, test4, test5 ,  test6 , test7,test8,");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
      end;

      --  Check that we have non empty log files (up to test8.log).
      for I in 1 .. 8 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
         begin
            T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
            if I > 5 then
               T.Assert (Ada.Directories.Size (Path) < 100, "Log file "
                         & Path & " should be empty");
            else
               T.Assert (Ada.Directories.Size (Path) > 100, "Log file " & Path & " is empty");
            end if;
         end;
      end loop;
   end Test_List_Appender;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_File_Appender_Modes (T : in out Test) is
      use Ada.Directories;

      Append_Path  : constant String := Util.Tests.Get_Test_Path ("test-append.log");
      Append2_Path : constant String := Util.Tests.Get_Test_Path ("test-append2.log");
      Global_Path  : constant String := Util.Tests.Get_Test_Path ("test-append-global.log");
      Props        : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Append_Path);
      Props.Set ("log4j.appender.test.append", "true");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.appender.test_global", "File");
      Props.Set ("log4j.appender.test_global.File", Global_Path);
      Props.Set ("log4j.appender.test_global.append", "false");
      Props.Set ("log4j.appender.test_global.immediateFlush", "false");
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG");
      Props.Set ("log4j.rootCategory", "DEBUG,test_global,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Error ("This is the error test message");
      end;

      Props.Set ("log4j.appender.test_append", "File");
      Props.Set ("log4j.appender.test_append.File", Append2_Path);
      Props.Set ("log4j.appender.test_append.append", "true");
      Props.Set ("log4j.appender.test_append.immediateFlush", "true");
      Props.Set ("log4j.logger.util.log.test2.file", "DEBUG,test_append,test_global");
      Util.Log.Loggers.Initialize (Props);

      declare
         L1 : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
         L2 : constant Loggers.Logger := Loggers.Create ("util.log.test2.file");
      begin
         L1.Info ("L1-1 Writing a info message");
         L2.Info ("L2-2 {0}: {1}", "Parameter", "Value");
         L1.Info ("L1-3 Done");
         L2.Error ("L2-4 This is the error test2 message");
      end;

      Props.Set ("log4j.appender.test_append.append", "plop");
      Props.Set ("log4j.appender.test_append.immediateFlush", "falsex");
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Util.Log.Loggers.Initialize (Props);

      T.Assert (Ada.Directories.Size (Append_Path) > 100,
                "Log file test-append.log is empty");
      T.Assert (Ada.Directories.Size (Append2_Path) > 100,
                "Log file test-append2.log is empty");
      T.Assert (Ada.Directories.Size (Global_Path) > 100,
                "Log file test-append.log is empty");
   end Test_File_Appender_Modes;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_Console_Appender (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test_err.log");
      Props   : Util.Properties.Manager;
      File    : Ada.Text_IO.File_Type;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Ada.Text_IO.Create (File, Ada.Text_IO.Out_File, Path);
      Ada.Text_IO.Set_Error (File);

      Props.Set ("log4j.appender.test_console", "Console");
      Props.Set ("log4j.appender.test_console.stderr", "true");
      Props.Set ("log4j.appender.test_console.level", "WARN");
      Props.Set ("log4j.rootCategory", "INFO,test_console");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Info ("INFO MESSAGE!");
         L.Warn ("WARN MESSAGE!");
         L.Error ("This {0} {1} {2} test message", "is", "the", "error");
      end;
      Ada.Text_IO.Flush (Ada.Text_IO.Current_Error);
      Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
      Ada.Text_IO.Close (File);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*WARN MESSAGE!", Content,
                                 "Invalid console log (WARN)");
      Util.Tests.Assert_Matches (T, ".*This is the error test message", Content,
                                 "Invalid console log (ERROR)");
   exception
      when others =>
         Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
         raise;

   end Test_Console_Appender;

   procedure Test_Missing_Config (T : in out Test) is
      L : constant Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      Util.Log.Loggers.Initialize ("plop");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
   end Test_Missing_Config;

   procedure Test_Log_Traceback (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test-traceback.log");
      Props   : Util.Properties.Manager;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.appender.test.append", "false");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.rootCategory", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Error ("This is the error test message");
         raise Constraint_Error with "Test";

      exception
         when E : others =>
            L.Error ("Something wrong", E, True);
      end;

      Props.Set ("log4j.rootCategory", "DEBUG,console");
      Props.Set ("log4j.appender.console", "Console");
      Util.Log.Loggers.Initialize (Props);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*Something wrong: Exception CONSTRAINT_ERROR:", Content,
                                 "Invalid console log (ERROR)");
   end Test_Log_Traceback;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Info",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Debug",
                       Test_Debug'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Set_Level",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Error",
                       Test_Log_Traceback'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Initialize",
                       Test_Missing_Config'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender",
                       Test_File_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender (append)",
                       Test_File_Appender_Modes'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.List_Appender",
                       Test_List_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.Console",
                       Test_Console_Appender'Access);

      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Log (Perf)",
                       Test_Log_Perf'Access);
   end Add_Tests;

end Util.Log.Tests;

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

with Ada.Strings.Fixed;
with Ada.Directories;
with Ada.Text_IO;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with Util.Log;
with Util.Log.Loggers;
with Util.Files;
with Util.Properties;
with Util.Measures;
package body Util.Log.Tests is

   Log : constant Loggers.Logger := Loggers.Create ("util.log.test");

   procedure Test_Log (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      L.Set_Level (DEBUG_LEVEL);
      Log.Info ("My log message");
      Log.Error ("My error message");
      Log.Debug ("A debug message Not printed");

      L.Info ("An info message");
      L.Info ("A {0} {1} {2} {3}", "info", "message", "not", "printed");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Log;

   procedure Test_Debug (T : in out Test) is
      L : Loggers.Logger := Loggers.Create ("util.log.test.debug");
      C : Ada.Strings.Unbounded.Unbounded_String;
   begin
      L.Set_Level (DEBUG_LEVEL);
      L.Info ("My log message");
      L.Error ("My error message");
      L.Debug ("A {0} {1} {2} {3}", "debug", "message", "not", "printed");
      L.Debug ("A {0} {1} {2} {3}", C, "message", "printed");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
      Util.Tests.Assert_Equals (T, "DEBUG", L.Get_Level_Name,
                               "Get_Level_Name function is invalid");
   end Test_Debug;

   --  Test configuration and creation of file
   procedure Test_File_Appender (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_File_Appender;

   procedure Test_Log_Perf (T : in out Test) is
      Path  : constant String := Util.Tests.Get_Test_Path ("test_perf.log");
      Props : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.logger.util.log.test.perf", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      for I in 1 .. 1000 loop
         declare
            S : Util.Measures.Stamp;
         begin
            Util.Measures.Report (S, "Util.Measures.Report", 1000);
         end;
      end loop;

      declare
         L : Loggers.Logger := Loggers.Create ("util.log.test.perf");
         S : Util.Measures.Stamp;
      begin
         L.Set_Level (DEBUG_LEVEL);
         for I in 1 .. 1000 loop
            L.Info ("My log message: {0}: {1}", "A message",
                    "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Info message (output)", 1000);

         L.Set_Level (INFO_LEVEL);
         for I in 1 .. 10_000 loop
            L.Debug ("My log message: {0}: {1}", "A message",
                     "A second parameter");
         end loop;
         Util.Measures.Report (S, "Log.Debug message (no output)", 10_000);
      end;
      T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
   end Test_Log_Perf;

   --  ------------------------------
   --  Test appending the log on several log files
   --  ------------------------------
   procedure Test_List_Appender (T : in out Test) is
      use Ada.Strings;
      use Ada.Directories;
      Props : Util.Properties.Manager;
   begin
      for I in 1 .. 10 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
            Name : constant String := "log4j.appender.test" & Id;
         begin
            Props.Set (Name, "File");
            Props.Set (Name & ".File", Path);
            Props.Set (Name & ".layout", "date-level-message");
            if I > 5 then
               Props.Set (Name & ".level", "INFO");
            end if;
         end;
      end loop;
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Props.Set ("log4j.appender.test.log.File",
                 Util.Tests.Get_Test_Path ("test-default.log"));
      Props.Set ("log4j.logger.util.log.test.file",
                 "DEBUG,test4,test1 , test2,test3, test4, test5 ,  test6 , test7,test8,");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
      end;

      --  Check that we have non empty log files (up to test8.log).
      for I in 1 .. 8 loop
         declare
            Id   : constant String := Fixed.Trim (Integer'Image (I), Both);
            Path : constant String := Util.Tests.Get_Test_Path ("test" & Id & ".log");
         begin
            T.Assert (Ada.Directories.Exists (Path), "Log file " & Path & " not found");
            if I > 5 then
               T.Assert (Ada.Directories.Size (Path) < 100, "Log file "
                         & Path & " should be empty");
            else
               T.Assert (Ada.Directories.Size (Path) > 100, "Log file " & Path & " is empty");
            end if;
         end;
      end loop;
   end Test_List_Appender;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_File_Appender_Modes (T : in out Test) is
      use Ada.Directories;

      Append_Path  : constant String := Util.Tests.Get_Test_Path ("test-append.log");
      Append2_Path : constant String := Util.Tests.Get_Test_Path ("test-append2.log");
      Global_Path  : constant String := Util.Tests.Get_Test_Path ("test-append-global.log");
      Props        : Util.Properties.Manager;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Append_Path);
      Props.Set ("log4j.appender.test.append", "true");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.appender.test_global", "File");
      Props.Set ("log4j.appender.test_global.File", Global_Path);
      Props.Set ("log4j.appender.test_global.append", "false");
      Props.Set ("log4j.appender.test_global.immediateFlush", "false");
      Props.Set ("log4j.logger.util.log.test.file", "DEBUG");
      Props.Set ("log4j.rootCategory", "DEBUG,test_global,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Error ("This is the error test message");
      end;

      Props.Set ("log4j.appender.test_append", "File");
      Props.Set ("log4j.appender.test_append.File", Append2_Path);
      Props.Set ("log4j.appender.test_append.append", "true");
      Props.Set ("log4j.appender.test_append.immediateFlush", "true");
      Props.Set ("log4j.logger.util.log.test2.file", "DEBUG,test_append,test_global");
      Util.Log.Loggers.Initialize (Props);

      declare
         L1 : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
         L2 : constant Loggers.Logger := Loggers.Create ("util.log.test2.file");
      begin
         L1.Info ("L1-1 Writing a info message");
         L2.Info ("L2-2 {0}: {1}", "Parameter", "Value");
         L1.Info ("L1-3 Done");
         L2.Error ("L2-4 This is the error test2 message");
      end;

      Props.Set ("log4j.appender.test_append.append", "plop");
      Props.Set ("log4j.appender.test_append.immediateFlush", "falsex");
      Props.Set ("log4j.rootCategory", "DEBUG, test.log");
      Util.Log.Loggers.Initialize (Props);

      T.Assert (Ada.Directories.Size (Append_Path) > 100,
                "Log file test-append.log is empty");
      T.Assert (Ada.Directories.Size (Append2_Path) > 100,
                "Log file test-append2.log is empty");
      T.Assert (Ada.Directories.Size (Global_Path) > 100,
                "Log file test-append.log is empty");
   end Test_File_Appender_Modes;

   --  ------------------------------
   --  Test file appender with different modes.
   --  ------------------------------
   procedure Test_Console_Appender (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test_err.log");
      Props   : Util.Properties.Manager;
      File    : Ada.Text_IO.File_Type;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Ada.Text_IO.Create (File, Ada.Text_IO.Out_File, Path);
      Ada.Text_IO.Set_Error (File);

      Props.Set ("log4j.appender.test_console", "Console");
      Props.Set ("log4j.appender.test_console.stderr", "true");
      Props.Set ("log4j.appender.test_console.level", "WARN");
      Props.Set ("log4j.rootCategory", "INFO,test_console");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Debug ("Writing a debug message");
         L.Debug ("{0}: {1}", "Parameter", "Value");
         L.Debug ("Done");
         L.Info ("INFO MESSAGE!");
         L.Warn ("WARN MESSAGE!");
         L.Error ("This {0} {1} {2} test message", "is", "the", "error");
      end;
      Ada.Text_IO.Flush (Ada.Text_IO.Current_Error);
      Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
      Ada.Text_IO.Close (File);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*WARN MESSAGE!", Content,
                                 "Invalid console log (WARN)");
      Util.Tests.Assert_Matches (T, ".*This is the error test message", Content,
                                 "Invalid console log (ERROR)");
   exception
      when others =>
         Ada.Text_IO.Set_Error (Ada.Text_IO.Standard_Error);
         raise;

   end Test_Console_Appender;

   procedure Test_Missing_Config (T : in out Test) is
      L : constant Loggers.Logger := Loggers.Create ("util.log.test.debug");
   begin
      Util.Log.Loggers.Initialize ("plop");

      L.Info ("An info message");
      L.Debug ("A debug message on logger 'L'");
   end Test_Missing_Config;

   procedure Test_Log_Traceback (T : in out Test) is
      Path    : constant String := Util.Tests.Get_Test_Path ("test-traceback.log");
      Props   : Util.Properties.Manager;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Props.Set ("log4j.appender.test", "File");
      Props.Set ("log4j.appender.test.File", Path);
      Props.Set ("log4j.appender.test.append", "false");
      Props.Set ("log4j.appender.test.immediateFlush", "true");
      Props.Set ("log4j.rootCategory", "DEBUG,test");
      Util.Log.Loggers.Initialize (Props);

      declare
         L : constant Loggers.Logger := Loggers.Create ("util.log.test.file");
      begin
         L.Error ("This is the error test message");
         raise Constraint_Error with "Test";

      exception
         when E : others =>
            L.Error ("Something wrong", E, True);
      end;

      Props.Set ("log4j.rootCategory", "DEBUG,console");
      Props.Set ("log4j.appender.console", "Console");
      Util.Log.Loggers.Initialize (Props);

      Util.Files.Read_File (Path, Content);
      Util.Tests.Assert_Matches (T, ".*Something wrong: Exception CONSTRAINT_ERROR:", Content,
                                 "Invalid console log (ERROR)");
   end Test_Log_Traceback;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Info",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Debug",
                       Test_Debug'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Set_Level",
                       Test_Log'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Error",
                       Test_Log_Traceback'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Initialize",
                       Test_Missing_Config'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender",
                       Test_File_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.File_Appender (append)",
                       Test_File_Appender_Modes'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.List_Appender",
                       Test_List_Appender'Access);
      Caller.Add_Test (Suite, "Test Util.Log.Appenders.Console",
                       Test_Console_Appender'Access);

      Caller.Add_Test (Suite, "Test Util.Log.Loggers.Log (Perf)",
                       Test_Log_Perf'Access);
   end Add_Tests;

end Util.Log.Tests;

Fix configuration of a unit test

Fix configuration of a unit test


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

with Util.Serialize.Mappers.Record_Mapper;

with EL.Utils;

with AWA.Services.Contexts;
package body AWA.Events.Configs is

   use AWA.Events.Queues;

   --  ------------------------------
   --  Set the configuration value identified by Value after having parsed
   --  the element identified by Field.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Ada.Strings.Unbounded;
      use Util.Beans.Objects;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_TYPE =>
            Into.Queue_Type := Value;

         when FIELD_QUEUE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Queue := Into.Manager.Find_Queue (Name);
            end;

         when FIELD_ACTION =>
            declare
               Expr : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Action := EL.Expressions.Create_Expression (Expr, Into.Context.all);

            exception
               when others =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Expr;
            end;

         when FIELD_PROPERTY_NAME =>
            Into.Prop_Name := Value;

         when FIELD_PROPERTY_VALUE =>
            if Util.Beans.Objects.Is_Null (Into.Prop_Name) then
               raise Util.Serialize.Mappers.Field_Error with "Missing property name";
            end if;

            --  Add the new property.
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Prop_Name);
               Expr : constant String := Util.Beans.Objects.To_String (Value);
            begin
               EL.Beans.Add_Parameter (Container => Into.Params,
                                       Name      => Name,
                                       Value     => Expr,
                                       Context   => Into.Context.all);
            end;
            Into.Prop_Name := Util.Beans.Objects.Null_Object;

         when FIELD_ON_EVENT =>
            if Util.Beans.Objects.Is_Null (Into.Name) then
               raise Util.Serialize.Mappers.Field_Error with "Missing event name";
            end if;

            declare
               Name  : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               Into.Manager.Add_Action (Event  => Name,
                                        Queue  => Into.Queue,
                                        Action => Into.Action,
                                        Params => Into.Params);
            end;
            Into.Name := Util.Beans.Objects.Null_Object;
            Into.Queue := AWA.Events.Queues.Null_Queue;
            Into.Params.Clear;

         when FIELD_QUEUE =>
            --  Create the queue with the given name and properties and add it to the manager.
            declare
               Name  : constant String := Util.Beans.Objects.To_String (Into.Name);
               Kind  : constant String := Util.Beans.Objects.To_String (Into.Queue_Type);
               Queue : constant Queue_Ref := Queues.Create_Queue (Name    => Name,
                                                                  Kind    => Kind,
                                                                  Props   => Into.Params,
                                                                  Context => Into.Context.all);
            begin
               Into.Manager.Add_Queue (Queue);
            end;

            Into.Name       := Util.Beans.Objects.Null_Object;
            Into.Queue_Type := Util.Beans.Objects.Null_Object;
            Into.Params.Clear;

         when FIELD_DISPATCHER_PRIORITY =>
            Into.Priority := To_Integer (EL.Utils.Eval (Value   => Value,
                                                        Context => Into.Context.all));

         when FIELD_DISPATCHER_COUNT =>
            Into.Count := To_Integer (EL.Utils.Eval (Value   => Value,
                                                     Context => Into.Context.all));

         when FIELD_DISPATCHER_QUEUE =>
            declare
               Match : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Length (Into.Match) > 0 then
                  Append (Into.Match, ",");
               end if;
               Append (Into.Match, Match);
            end;

         when FIELD_DISPATCHER =>
            if Into.Count > 0 then
               Into.Manager.Add_Dispatcher (Match    => To_String (Into.Match),
                                            Count    => Into.Count,
                                            Priority => Into.Priority);
            end if;
            Into.Match := To_Unbounded_String ("");

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  Setup the XML parser to read the queue and on-event description.
   --  For example:
   --
   --  <queue name="async" type="fifo">
   --     <property name="size">254</property>
   --  </queue>
   --
   --  <on-event name="create-user" queue="async">
   --     <action>#{mail.send}</action>
   --     <property name="user">#{event.name}</property>
   --     <property name="template">mail/welcome.xhtml</property>
   --  </on-event>
   --
   --  This defines an event action called when the create-user event is posted.
   --  The Ada bean mail is created and is populated with the user and
   --  template properties.  The Ada bean action method send is called.
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager     := Manager;
      Config.Context     := Context;
      Config.Session     := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("queue", FIELD_QUEUE);
   Mapper.Add_Mapping ("queue/@name", FIELD_NAME);
   Mapper.Add_Mapping ("queue/@type", FIELD_TYPE);
   Mapper.Add_Mapping ("queue/property/@name", FIELD_PROPERTY_NAME);
   Mapper.Add_Mapping ("queue/property", FIELD_PROPERTY_VALUE);
   Mapper.Add_Mapping ("on-event", FIELD_ON_EVENT);
   Mapper.Add_Mapping ("on-event/@name", FIELD_NAME);
   Mapper.Add_Mapping ("on-event/@queue", FIELD_QUEUE_NAME);
   Mapper.Add_Mapping ("on-event/property/@name", FIELD_PROPERTY_NAME);
   Mapper.Add_Mapping ("on-event/property", FIELD_PROPERTY_VALUE);
   Mapper.Add_Mapping ("on-event/action", FIELD_ACTION);
   Mapper.Add_Mapping ("dispatcher", FIELD_DISPATCHER);
   Mapper.Add_Mapping ("dispatcher/@name", FIELD_NAME);
   Mapper.Add_Mapping ("dispatcher/queue/@match", FIELD_DISPATCHER_QUEUE);
   Mapper.Add_Mapping ("dispatcher/priority", FIELD_DISPATCHER_PRIORITY);
   Mapper.Add_Mapping ("dispatcher/count", FIELD_DISPATCHER_COUNT);
end AWA.Events.Configs;

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

with Util.Serialize.Mappers.Record_Mapper;

with EL.Utils;

with AWA.Services.Contexts;
package body AWA.Events.Configs is

   use AWA.Events.Queues;

   --  ------------------------------
   --  Set the configuration value identified by Value after having parsed
   --  the element identified by Field.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Ada.Strings.Unbounded;
      use Util.Beans.Objects;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_TYPE =>
            Into.Queue_Type := Value;

         when FIELD_QUEUE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Queue := Into.Manager.Find_Queue (Name);
            end;

         when FIELD_ACTION =>
            declare
               Expr : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Action := EL.Expressions.Create_Expression (Expr, Into.Context.all);

            exception
               when others =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Expr;
            end;

         when FIELD_PROPERTY_NAME =>
            Into.Prop_Name := Value;

         when FIELD_PROPERTY_VALUE =>
            if Util.Beans.Objects.Is_Null (Into.Prop_Name) then
               raise Util.Serialize.Mappers.Field_Error with "Missing property name";
            end if;

            --  Add the new property.
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Prop_Name);
               Expr : constant String := Util.Beans.Objects.To_String (Value);
            begin
               EL.Beans.Add_Parameter (Container => Into.Params,
                                       Name      => Name,
                                       Value     => Expr,
                                       Context   => Into.Context.all);
            end;
            Into.Prop_Name := Util.Beans.Objects.Null_Object;

         when FIELD_ON_EVENT =>
            if Util.Beans.Objects.Is_Null (Into.Name) then
               raise Util.Serialize.Mappers.Field_Error with "Missing event name";
            end if;

            declare
               Name  : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               Into.Manager.Add_Action (Event  => Name,
                                        Queue  => Into.Queue,
                                        Action => Into.Action,
                                        Params => Into.Params);
            end;
            Into.Name := Util.Beans.Objects.Null_Object;
            Into.Queue := AWA.Events.Queues.Null_Queue;
            Into.Params.Clear;

         when FIELD_QUEUE =>
            --  Create the queue with the given name and properties and add it to the manager.
            declare
               Name  : constant String := Util.Beans.Objects.To_String (Into.Name);
               Kind  : constant String := Util.Beans.Objects.To_String (Into.Queue_Type);
               Queue : constant Queue_Ref := Queues.Create_Queue (Name    => Name,
                                                                  Kind    => Kind,
                                                                  Props   => Into.Params,
                                                                  Context => Into.Context.all);
            begin
               Into.Manager.Add_Queue (Queue);
            end;

            Into.Name       := Util.Beans.Objects.Null_Object;
            Into.Queue_Type := Util.Beans.Objects.Null_Object;
            Into.Params.Clear;

         when FIELD_DISPATCHER_PRIORITY =>
            Into.Priority := To_Integer (EL.Utils.Eval (Value   => Value,
                                                        Context => Into.Context.all));

         when FIELD_DISPATCHER_COUNT =>
            Into.Count := To_Integer (EL.Utils.Eval (Value   => Value,
                                                     Context => Into.Context.all));

         when FIELD_DISPATCHER_QUEUE =>
            declare
               Match : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Length (Into.Match) > 0 then
                  Append (Into.Match, ",");
               end if;
               Append (Into.Match, Match);
            end;

         when FIELD_DISPATCHER =>
            if Into.Count > 0 then
               Into.Manager.Add_Dispatcher (Match    => To_String (Into.Match),
                                            Count    => Into.Count,
                                            Priority => Into.Priority);
            end if;
            Into.Match := To_Unbounded_String ("");

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Event_Mapper : aliased Config_Mapper.Mapper;

   --  Setup the XML parser to read the queue and on-event description.
   --  For example:
   --
   --  <queue name="async" type="fifo">
   --     <property name="size">254</property>
   --  </queue>
   --
   --  <on-event name="create-user" queue="async">
   --     <action>#{mail.send}</action>
   --     <property name="user">#{event.name}</property>
   --     <property name="template">mail/welcome.xhtml</property>
   --  </on-event>
   --
   --  This defines an event action called when the create-user event is posted.
   --  The Ada bean mail is created and is populated with the user and
   --  template properties.  The Ada bean action method send is called.
   package body Reader_Config is
   begin
      Mapper.Add_Mapping ("module", Event_Mapper'Access);
      Config.Manager     := Manager;
      Config.Context     := Context;
      Config.Session     := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Mapper, Config'Unchecked_Access);
   end Reader_Config;

begin
   Event_Mapper.Add_Mapping ("queue", FIELD_QUEUE);
   Event_Mapper.Add_Mapping ("queue/@name", FIELD_NAME);
   Event_Mapper.Add_Mapping ("queue/@type", FIELD_TYPE);
   Event_Mapper.Add_Mapping ("queue/property/@name", FIELD_PROPERTY_NAME);
   Event_Mapper.Add_Mapping ("queue/property", FIELD_PROPERTY_VALUE);
   Event_Mapper.Add_Mapping ("on-event", FIELD_ON_EVENT);
   Event_Mapper.Add_Mapping ("on-event/@name", FIELD_NAME);
   Event_Mapper.Add_Mapping ("on-event/@queue", FIELD_QUEUE_NAME);
   Event_Mapper.Add_Mapping ("on-event/property/@name", FIELD_PROPERTY_NAME);
   Event_Mapper.Add_Mapping ("on-event/property", FIELD_PROPERTY_VALUE);
   Event_Mapper.Add_Mapping ("on-event/action", FIELD_ACTION);
   Event_Mapper.Add_Mapping ("dispatcher", FIELD_DISPATCHER);
   Event_Mapper.Add_Mapping ("dispatcher/@name", FIELD_NAME);
   Event_Mapper.Add_Mapping ("dispatcher/queue/@match", FIELD_DISPATCHER_QUEUE);
   Event_Mapper.Add_Mapping ("dispatcher/priority", FIELD_DISPATCHER_PRIORITY);
   Event_Mapper.Add_Mapping ("dispatcher/count", FIELD_DISPATCHER_COUNT);
end AWA.Events.Configs;

Update the Prepare_Config to use the new parser/mapper interface


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

with Util.Streams.Files;
package body ADO is

   use Util.Refs;
   use Ada.Streams;

   --  ------------------------------
   --  Create a blob with an allocated buffer of Size bytes.
   --  ------------------------------
   function Create_Blob (Size : in Natural) return Blob_Ref is
      B :  constant Blob_Access := new Blob '(Ref_Entity with
                                              Len    => Stream_Element_Offset (Size),
                                              others => <>);
   begin
      return Blob_References.Create (B);
   end Create_Blob;

   --  ------------------------------
   --  Create a blob initialized with the given data buffer.
   --  ------------------------------
   function Create_Blob (Data : in Ada.Streams.Stream_Element_Array) return Blob_Ref is
      B   :  constant Blob_Access := new Blob '(Ref_Entity with
                                                Len    => Data'Length,
                                                Data   => Data);
   begin
      return Blob_References.Create (B);
   end Create_Blob;

   --  ------------------------------
   --  Create a blob initialized with the content from the file whose path is Path.
   --  Raises an IO exception if the file does not exist.
   --  ------------------------------
   function Create_Blob (Path : in String) return Blob_Ref is
      Size : constant Stream_Element_Offset := Stream_Element_Offset (Ada.Directories.Size (Path));
      File : Util.Streams.Files.File_Stream;
      Last : Stream_Element_Offset;
   begin
      File.Open (Name => Path, Mode => Ada.Streams.Stream_IO.In_File);
      declare
         B    : constant Blob_Access := new Blob '(Ref_Entity with
                                                   Len    => Size,
                                                   others => <>);
      begin
         File.Read (Into => B.Data, Last => Last);
         File.Close;
         return Blob_References.Create (B);
      end;
   end Create_Blob;

   Null_Blob_Instance : Blob_Ref;

   --  ------------------------------
   --  Return a null blob.
   --  ------------------------------
   function Null_Blob return Blob_Ref is
   begin
      return Null_Blob_Instance;
   end Null_Blob;

end ADO;

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

with Util.Streams.Files;
package body ADO is

   use Util.Refs;
   use Ada.Streams;

   --  ------------------------------
   --  Create a blob with an allocated buffer of Size bytes.
   --  ------------------------------
   function Create_Blob (Size : in Natural) return Blob_Ref is
      B :  constant Blob_Access := new Blob '(Ref_Entity with
                                              Len    => Stream_Element_Offset (Size),
                                              others => <>);
   begin
      return Blob_References.Create (B);
   end Create_Blob;

   --  ------------------------------
   --  Create a blob initialized with the given data buffer.
   --  ------------------------------
   function Create_Blob (Data : in Ada.Streams.Stream_Element_Array) return Blob_Ref is
      B   :  constant Blob_Access := new Blob '(Ref_Entity with
                                                Len    => Data'Length,
                                                Data   => Data);
   begin
      return Blob_References.Create (B);
   end Create_Blob;

   --  ------------------------------
   --  Create a blob initialized with the content from the file whose path is Path.
   --  Raises an IO exception if the file does not exist.
   --  ------------------------------
   function Create_Blob (Path : in String) return Blob_Ref is
      Size : constant Stream_Element_Offset := Stream_Element_Offset (Ada.Directories.Size (Path));
      File : Util.Streams.Files.File_Stream;
      Last : Stream_Element_Offset;
   begin
      File.Open (Name => Path, Mode => Ada.Streams.Stream_IO.In_File);
      declare
         B    : constant Blob_Access := new Blob '(Ref_Entity with
                                                   Len    => Size,
                                                   others => <>);
      begin
         File.Read (Into => B.Data, Last => Last);
         File.Close;
         return Blob_References.Create (B);
      end;
   end Create_Blob;

   Null_Blob_Instance : Blob_Ref;

   --  ------------------------------
   --  Return a null blob.
   --  ------------------------------
   function Null_Blob return Blob_Ref is
   begin
      return Null_Blob_Instance;
   end Null_Blob;

   --  ------------------------------
   --  Return True if the two nullable times are identical (both null or both same time).
   --  ------------------------------
   function "=" (Left, Right : in Nullable_Time) return Boolean is
      use type Ada.Calendar.Time;
   begin
      if Left.Is_Null /= Right.Is_Null then
         return False;
      elsif Left.Is_Null then
         return True;
      else
         return Left.Value = Right.Value;
      end if;
   end "=";

end ADO;

Implement the "=" function operator to compare a nullable_time on the is_null first and on the value when they are not null only


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

package body MAT.Frames.Targets is

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in out Target_Frames;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
   begin
      Frame.Frames.Insert (Pc, Result);
   end Insert;

   --  ------------------------------
   --  Get the number of different stack frames which have been registered.
   --  ------------------------------
   function Get_Frame_Count (Frame : in Target_Frames) return Natural is
   begin
      return Frame.Frames.Get_Frame_Count;
   end Get_Frame_Count;

   protected body Frames_Type is

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Insert (Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      begin
         MAT.Frames.Insert (Root, Pc, Result);
      end Insert;

      --  ------------------------------
      --  Clear and destroy all the frame instances.
      --  ------------------------------
      procedure Clear is
      begin
         Destroy (Root);
      end Clear;

   end Frames_Type;

   --  ------------------------------
   --  Release all the stack frames.
   --  ------------------------------
   overriding
   procedure Finalize (Frames : in out Target_Frames) is
   begin
      Frames.Frames.Clear;
   end Finalize;

end MAT.Frames.Targets;

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

package body MAT.Frames.Targets is

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in out Target_Frames;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
   begin
      Frame.Frames.Insert (Pc, Result);
   end Insert;

   --  ------------------------------
   --  Get the number of different stack frames which have been registered.
   --  ------------------------------
   function Get_Frame_Count (Frame : in Target_Frames) return Natural is
   begin
      return Frame.Frames.Get_Frame_Count;
   end Get_Frame_Count;

   protected body Frames_Type is

      --  ------------------------------
      --  Get the number of different stack frames which have been registered.
      --  ------------------------------
      function Get_Frame_Count return Natural is
      begin
         return Root.Used;
      end Get_Frame_Count;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Insert (Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      begin
         MAT.Frames.Insert (Root, Pc, Result);
      end Insert;

      --  ------------------------------
      --  Clear and destroy all the frame instances.
      --  ------------------------------
      procedure Clear is
      begin
         Destroy (Root);
      end Clear;

   end Frames_Type;

   --  ------------------------------
   --  Release all the stack frames.
   --  ------------------------------
   overriding
   procedure Finalize (Frames : in out Target_Frames) is
   begin
      Frames.Frames.Clear;
   end Finalize;

end MAT.Frames.Targets;

Implement the protected operation Get_Frame_Count


-----------------------------------------------------------------------
--  mat-readers-sockets -- Reader for TCP/IP sockets
--  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 Ada.Finalization;

with Util.Streams.Sockets;
with GNAT.Sockets;
package MAT.Readers.Streams.Sockets is

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with private;

   --  Initialize the socket listener.
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type);

   --  Destroy the socket listener.
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type);

   --  Open the socket to accept connections and start the listener task.
   procedure Start (Listener : in out Socket_Listener_Type;
                    Address  : in GNAT.Sockets.Sock_Addr_Type);

   --  Stop the listener socket.
   procedure Stop (Listener : in out Socket_Listener_Type);

   --  Create a target instance for the new client.
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type);

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with private;
   type Socket_Reader_Type_Access is access all Socket_Reader_Type'Class;

   --  Open the socket to accept connections.
   procedure Open (Reader  : in out Socket_Reader_Type;
                   Address : in GNAT.Sockets.Sock_Addr_Type);

   procedure Close (Reader : in out Socket_Reader_Type);

private

   type Socket_Listener_Type_Access is access all Socket_Listener_Type;

   task type Socket_Listener_Task is
      entry Start (Listener : in Socket_Listener_Type_Access;
                   Address  : in GNAT.Sockets.Sock_Addr_Type);
   end Socket_Listener_Task;

   task type Socket_Reader_Task is
      entry Start (Reader  : in Socket_Reader_Type_Access;
                   Client  : in GNAT.Sockets.Socket_Type);
   end Socket_Reader_Task;

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with record
      Socket : aliased Util.Streams.Sockets.Socket_Stream;
      Server : Socket_Reader_Task;
      Stop   : Boolean := False;
   end record;

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with record
      Accept_Selector : aliased GNAT.Sockets.Selector_Type;
      Listener        : Socket_Listener_Task;
   end record;

end MAT.Readers.Streams.Sockets;

-----------------------------------------------------------------------
--  mat-readers-sockets -- Reader for TCP/IP sockets
--  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 Ada.Finalization;

with Util.Streams.Sockets;
with GNAT.Sockets;
package MAT.Readers.Streams.Sockets is

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with private;

   --  Initialize the socket listener.
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type);

   --  Destroy the socket listener.
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type);

   --  Open the socket to accept connections and start the listener task.
   procedure Start (Listener : in out Socket_Listener_Type;
                    Address  : in GNAT.Sockets.Sock_Addr_Type);

   --  Stop the listener socket.
   procedure Stop (Listener : in out Socket_Listener_Type);

   --  Create a target instance for the new client.
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type);

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with private;
   type Socket_Reader_Type_Access is access all Socket_Reader_Type'Class;

   procedure Close (Reader : in out Socket_Reader_Type);

private

   type Socket_Listener_Type_Access is access all Socket_Listener_Type;

   task type Socket_Listener_Task is
      entry Start (Listener : in Socket_Listener_Type_Access;
                   Address  : in GNAT.Sockets.Sock_Addr_Type);
   end Socket_Listener_Task;

   task type Socket_Reader_Task is
      entry Start (Reader  : in Socket_Reader_Type_Access;
                   Client  : in GNAT.Sockets.Socket_Type);
   end Socket_Reader_Task;

   type Socket_Reader_Type is new MAT.Readers.Streams.Stream_Reader_Type with record
      Socket : aliased Util.Streams.Sockets.Socket_Stream;
      Server : Socket_Reader_Task;
      Stop   : Boolean := False;
   end record;

   type Socket_Listener_Type is new Ada.Finalization.Limited_Controlled with record
      Accept_Selector : aliased GNAT.Sockets.Selector_Type;
      Listener        : Socket_Listener_Task;
   end record;

end MAT.Readers.Streams.Sockets;

Remove the Open procedure

Remove the Open procedure


with Ada.Strings.Fixed;

package body Test is
  package Text_IO       renames Ada.Text_IO;
  package Result_IO     is new  Ada.Text_IO.Enumeration_IO (Result_t);
  package Fixed_Strings renames Ada.Strings.Fixed;
  package Strings       renames Ada.Strings;

  use type UB_Strings.Unbounded_String;

  --
  -- Check
  --

  procedure Check
    (Test_Context : in Context_t;
     Test         : in Test_t;
     Condition    : in Boolean;
     Statement    : in String := "")
  is
    Result : Valid_Result_t;
  begin
    if Condition then
      Result := Pass;
    else
      Result := Fail;
    end if;

    Satisfy
      (Test_Context => Test_Context,
       Test         => Test,
       Result       => Result,
       Statement    => Statement);
  end Check;

  --
  -- Check_Program
  --

  procedure Check_Program
    (Test_Context : in Context_t;
     Base         : in UB_Strings.Unbounded_String)
  is
    Want_Program : UB_Strings.Unbounded_String;
    Path         : UB_Strings.Unbounded_String;
    File         : Text_IO.File_Type;
  begin
    UB_Strings.Append (Path, Test_Context.Test_DB);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/program");

    Text_IO.Open
      (File => File,
       Mode => Text_IO.In_File,
       Name => UB_Strings.To_String (Path));

    Want_Program := UB_Strings.To_Unbounded_String (Text_IO.Get_Line (File));

    if Want_Program /= Test_Context.Program then
      raise Program_Error with "program does not match test database";
    end if;
  end Check_Program;

  --
  -- Initialize
  --

  procedure Initialize
    (Test_Context :    out Context_t;
     Program      : in     String;
     Test_DB      : in     String;
     Test_Results : in     String) is
  begin
    Test_Context.Program      := UB_Strings.To_Unbounded_String (Program);
    Test_Context.Test_DB      := UB_Strings.To_Unbounded_String (Test_DB);
    Test_Context.Test_Results := UB_Strings.To_Unbounded_String (Test_Results);

    Text_IO.Create
      (File => Test_Context.Output_File,
       Name => Program & ".log_out",
       Mode => Text_IO.Out_File);
    Text_IO.Create
      (File => Test_Context.Error_File,
       Name => Program & ".log_error",
       Mode => Text_IO.Out_File);

    Text_IO.Set_Output (Test_Context.Output_File);
    Text_IO.Set_Error  (Test_Context.Error_File);
  end Initialize;

  --
  -- Satisfy
  --

  procedure Satisfy
    (Test_Context : in Context_t;
     Test         : in Test_t;
     Result       : in Valid_Result_t;
     Statement    : in String := "")
  is
    File : Text_IO.File_Type;
    Base : UB_Strings.Unbounded_String;
    Path : UB_Strings.Unbounded_String;
  begin
    -- Build path to test entry.
    UB_Strings.Set_Unbounded_String (Base, "");
    UB_Strings.Append (Base, "/tests/");
    UB_Strings.Append (Base, Fixed_Strings.Trim (Test_t'Image (Test), Strings.Left));

    -- Check the current program is the one that should be satisfying the test.
    Check_Program (Test_Context, Base);

    -- Build path to state file.
    UB_Strings.Set_Unbounded_String (Path, "");
    UB_Strings.Append (Path, Test_Context.Test_Results);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/statement");

    -- Yes, Ada has race conditions built in!
    Text_IO.Create   (File, Name => UB_Strings.To_String (Path));
    Text_IO.Put      (File, Statement);
    Text_IO.New_Line (File);
    Text_IO.Close    (File);

    -- Build path to state file.
    UB_Strings.Set_Unbounded_String (Path, "");
    UB_Strings.Append (Path, Test_Context.Test_Results);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/state");

    -- Yes, Ada has race conditions built in!
    Text_IO.Create   (File, Name => UB_Strings.To_String (Path));
    Result_IO.Put    (File, Result);
    Text_IO.New_Line (File);
  end Satisfy;

end Test;

with Ada.Strings.Fixed;
with Ada.Directories;

package body Test is
  package Text_IO       renames Ada.Text_IO;
  package Result_IO     is new  Ada.Text_IO.Enumeration_IO (Result_t);
  package Fixed_Strings renames Ada.Strings.Fixed;
  package Strings       renames Ada.Strings;
  package Directories   renames Ada.Directories;

  use type UB_Strings.Unbounded_String;

  --
  -- Check
  --

  procedure Check
    (Test_Context : in Context_t;
     Test         : in Test_t;
     Condition    : in Boolean;
     Statement    : in String := "")
  is
    Result : Valid_Result_t;
  begin
    if Condition then
      Result := Pass;
    else
      Result := Fail;
    end if;

    Satisfy
      (Test_Context => Test_Context,
       Test         => Test,
       Result       => Result,
       Statement    => Statement);
  end Check;

  --
  -- Check_Program
  --

  procedure Check_Program
    (Test_Context : in Context_t;
     Base         : in UB_Strings.Unbounded_String)
  is
    Want_Program : UB_Strings.Unbounded_String;
    Path         : UB_Strings.Unbounded_String;
    File         : Text_IO.File_Type;
  begin
    UB_Strings.Append (Path, Test_Context.Test_DB);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/program");

    Text_IO.Open
      (File => File,
       Mode => Text_IO.In_File,
       Name => UB_Strings.To_String (Path));

    Want_Program := UB_Strings.To_Unbounded_String (Text_IO.Get_Line (File));

    if Want_Program /= Test_Context.Program then
      raise Program_Error with "program does not match test database";
    end if;
  end Check_Program;

  --
  -- Initialize
  --

  procedure Initialize
    (Test_Context :    out Context_t;
     Program      : in     String;
     Test_DB      : in     String;
     Test_Results : in     String) is
  begin
    Test_Context.Program      := UB_Strings.To_Unbounded_String (Program);
    Test_Context.Test_DB      := UB_Strings.To_Unbounded_String (Test_DB);
    Test_Context.Test_Results := UB_Strings.To_Unbounded_String (Test_Results);

    Text_IO.Create
      (File => Test_Context.Output_File,
       Name => Program & ".log_out",
       Mode => Text_IO.Out_File);
    Text_IO.Create
      (File => Test_Context.Error_File,
       Name => Program & ".log_error",
       Mode => Text_IO.Out_File);

    Text_IO.Set_Output (Test_Context.Output_File);
    Text_IO.Set_Error  (Test_Context.Error_File);
  end Initialize;

  --
  -- Satisfy
  --

  procedure Satisfy
    (Test_Context : in Context_t;
     Test         : in Test_t;
     Result       : in Valid_Result_t;
     Statement    : in String := "")
  is
    File : Text_IO.File_Type;
    Base : UB_Strings.Unbounded_String;
    Path : UB_Strings.Unbounded_String;
  begin
    -- Build path to test entry.
    UB_Strings.Set_Unbounded_String (Base, "");
    UB_Strings.Append (Base, "/tests/");
    UB_Strings.Append (Base, Fixed_Strings.Trim (Test_t'Image (Test), Strings.Left));

    -- Check database entry exists.
    UB_Strings.Set_Unbounded_String (Path, "");
    UB_Strings.Append (Path, Test_Context.Test_DB);
    UB_Strings.Append (Path, Base);

    if Directories.Exists (UB_Strings.To_String (Path)) = False then
      raise Program_Error with
        "test " & Fixed_Strings.Trim (Test_t'Image (Test), Strings.Left) & " not defined";
    end if;

    -- Check the current program is the one that should be satisfying the test.
    Check_Program (Test_Context, Base);

    -- Build path to state file.
    UB_Strings.Set_Unbounded_String (Path, "");
    UB_Strings.Append (Path, Test_Context.Test_Results);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/statement");

    -- Yes, Ada has race conditions built in!
    Text_IO.Create   (File, Name => UB_Strings.To_String (Path));
    Text_IO.Put      (File, Statement);
    Text_IO.New_Line (File);
    Text_IO.Close    (File);

    -- Build path to state file.
    UB_Strings.Set_Unbounded_String (Path, "");
    UB_Strings.Append (Path, Test_Context.Test_Results);
    UB_Strings.Append (Path, Base);
    UB_Strings.Append (Path, "/state");

    -- Yes, Ada has race conditions built in!
    Text_IO.Create   (File, Name => UB_Strings.To_String (Path));
    Result_IO.Put    (File, Result);
    Text_IO.New_Line (File);
  end Satisfy;

end Test;

Check test entry in ada code

Check test entry in ada code


-----------------------------------------------------------------------
--  util-streams-raw -- Raw streams for Windows based systems
--  Copyright (C) 2011, 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 Ada.IO_Exceptions;

with System;

package body Util.Streams.Raw is

   use System;
   use Util.Systems.Os;
   use type Util.Systems.Os.HANDLE;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Get the file descriptor associated with the stream.
   --  -----------------------
   function Get_File (Stream : in Raw_Stream) return Util.Systems.Os.File_Type is
   begin
      return Stream.File;
   end Get_File;

   --  -----------------------
   --  Set the file descriptor to be used by the stream.
   --  -----------------------
   procedure Set_File (Stream : in out Raw_Stream;
                       File   : in Util.Systems.Os.File_Type) is
   begin
      Stream.File := File;
   end Set_File;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
      Error : Integer;
   begin
      if Stream.File /= NO_FILE then
         if Close_Handle (Stream.File) = 0 then
            Error := Get_Last_Error;
            if Error /= ERROR_BROKEN_PIPE then
               raise Ada.IO_Exceptions.Device_Error with "IO error: " & Integer'Image (Error);
            end if;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Res    : aliased DWORD := 0;
      Status : BOOL;
   begin
      Status := Write_File (Stream.File, Buffer'Address, Buffer'Length,
                            Res'Unchecked_Access, System.Null_Address);
      if Status = 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res    : aliased DWORD := 0;
      Status : BOOL;
      Error  : Integer;
   begin
      Status := Read_File (Stream.File, Into'Address, Into'Length,
                           Res'Unchecked_Access, System.Null_Address);
      if Status = 0 then
         Error := Get_Last_Error;
         if Error /= ERROR_BROKEN_PIPE then
            raise Ada.IO_Exceptions.Device_Error with "IO error: " & Integer'Image (Error);
         end if;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

-----------------------------------------------------------------------
--  util-streams-raw -- Raw streams for Windows based systems
--  Copyright (C) 2011, 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 Ada.IO_Exceptions;

with System;

package body Util.Streams.Raw is

   use System;
   use Util.Systems.Os;
   use type Util.Systems.Os.HANDLE;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Get the file descriptor associated with the stream.
   --  -----------------------
   function Get_File (Stream : in Raw_Stream) return Util.Systems.Os.File_Type is
   begin
      return Stream.File;
   end Get_File;

   --  -----------------------
   --  Set the file descriptor to be used by the stream.
   --  -----------------------
   procedure Set_File (Stream : in out Raw_Stream;
                       File   : in Util.Systems.Os.File_Type) is
   begin
      Stream.File := File;
   end Set_File;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
      Error : Integer;
   begin
      if Stream.File /= NO_FILE then
         if Close_Handle (Stream.File) = 0 then
            Error := Get_Last_Error;
            if Error /= ERROR_BROKEN_PIPE then
               raise Ada.IO_Exceptions.Device_Error with "IO error: " & Integer'Image (Error);
            end if;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Res    : aliased DWORD := 0;
      Status : BOOL;
   begin
      Status := Write_File (Stream.File, Buffer'Address, Buffer'Length,
                            Res'Unchecked_Access, System.Null_Address);
      if Status = 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res    : aliased DWORD := 0;
      Status : BOOL;
      Error  : Integer;
   begin
      Status := Read_File (Stream.File, Into'Address, Into'Length,
                           Res'Unchecked_Access, System.Null_Address);
      if Status = 0 then
         Error := Get_Last_Error;
         if Error /= ERROR_BROKEN_PIPE then
            raise Ada.IO_Exceptions.Device_Error with "IO error: " & Integer'Image (Error);
         end if;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

Implement the Seek procedure

Implement the Seek procedure


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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_START_TIME,
                       F_END_TIME,
                       F_MALLOC_COUNT,
                       F_REALLOC_COUNT,
                       F_FREE_COUNT,
                       F_EVENT_RANGE,
                       F_ID,
                       F_OLD_ADDR,
                       F_GROW_SIZE,
                       F_TIME,
                       F_DURATION,
                       F_EVENT,
                       F_MODE,
                       F_FRAME_ID,
                       F_RANGE_ADDR,
                       F_FRAME_ADDR);

   type Notice_Type is (N_HELP,
                        N_INFO,
                        N_EVENT_ID,
                        N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the address range and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the time tick as a duration and print it for the given field.
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_LEVEL,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_START_TIME,
                       F_END_TIME,
                       F_MALLOC_COUNT,
                       F_REALLOC_COUNT,
                       F_FREE_COUNT,
                       F_EVENT_RANGE,
                       F_ID,
                       F_OLD_ADDR,
                       F_GROW_SIZE,
                       F_TIME,
                       F_DURATION,
                       F_EVENT,
                       F_MODE,
                       F_FRAME_ID,
                       F_RANGE_ADDR,
                       F_FRAME_ADDR);

   type Notice_Type is (N_HELP,
                        N_INFO,
                        N_EVENT_ID,
                        N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the address range and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the time tick as a duration and print it for the given field.
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

Add F_LEVEL

Add F_LEVEL