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

with Util.Log.Loggers;

with ADO.Sessions;
with Security.Permissions;

with AWA.Users.Models;
with AWA.Permissions;
with AWA.Modules.Beans;
with AWA.Services.Contexts;
with AWA.Comments.Beans;

package body AWA.Comments.Modules is

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

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

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

      --  Register the comment list bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Comments.Beans.Comment_List_Bean",
                         Handler => AWA.Comments.Beans.Create_Comment_List_Bean'Access);

      --  Register the comment bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Comments.Beans.Comment_Bean",
                         Handler => AWA.Comments.Beans.Create_Comment_Bean'Access);

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

   --  ------------------------------
   --  Load the comment identified by the given identifier.
   --  ------------------------------
   procedure Load_Comment (Model   : in Comment_Module;
                           Comment : in out AWA.Comments.Models.Comment_Ref'Class;
                           Id      : in ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
      Found : Boolean;
   begin
      Comment.Load (DB, Id, Found);
   end Load_Comment;

   --  Create a new comment for the associated database entity.
   procedure Create_Comment (Model      : in Comment_Module;
                             Permission : in String;
                             Comment    : in out AWA.Comments.Models.Comment_Ref'Class) is
      pragma Unreferenced (Model);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      Log.Info ("Creating new comment for {0}", ADO.Identifier'Image (Comment.Get_Entity_Id));

      --  Check that the user has the create permission on the given workspace.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Comment.Get_Entity_Id);

      Comment.Set_Author (User);
      Comment.Set_Create_Date (Ada.Calendar.Clock);
      Comment.Save (DB);
      Ctx.Commit;
   end Create_Comment;

end AWA.Comments.Modules;

-----------------------------------------------------------------------
--  awa-comments-module -- Comments module
--  Copyright (C) 2011, 2012, 2013, 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.Calendar;

with Util.Log.Loggers;

with ADO.Sessions;
with ADO.Sessions.Entities;
with Security.Permissions;

with AWA.Users.Models;
with AWA.Permissions;
with AWA.Modules.Beans;
with AWA.Services.Contexts;
with AWA.Comments.Beans;

package body AWA.Comments.Modules is

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

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

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

      --  Register the comment list bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Comments.Beans.Comment_List_Bean",
                         Handler => AWA.Comments.Beans.Create_Comment_List_Bean'Access);

      --  Register the comment bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Comments.Beans.Comment_Bean",
                         Handler => AWA.Comments.Beans.Create_Comment_Bean'Access);

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

   --  ------------------------------
   --  Load the comment identified by the given identifier.
   --  ------------------------------
   procedure Load_Comment (Model   : in Comment_Module;
                           Comment : in out AWA.Comments.Models.Comment_Ref'Class;
                           Id      : in ADO.Identifier) is
      pragma Unreferenced (Model);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
      Found : Boolean;
   begin
      Comment.Load (DB, Id, Found);
   end Load_Comment;

   --  ------------------------------
   --  Create a new comment for the associated database entity.
   --  ------------------------------
   procedure Create_Comment (Model       : in Comment_Module;
                             Permission  : in String;
                             Entity_Type : in String;
                             Comment     : in out AWA.Comments.Models.Comment_Ref'Class) is
      pragma Unreferenced (Model);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      Log.Info ("Creating new comment for {0}", ADO.Identifier'Image (Comment.Get_Entity_Id));

      --  Check that the user has the create permission on the given workspace.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Comment.Get_Entity_Id);

      Comment.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type));
      Comment.Set_Author (User);
      Comment.Set_Create_Date (Ada.Calendar.Clock);
      Comment.Save (DB);
      Ctx.Commit;
   end Create_Comment;

end AWA.Comments.Modules;

Use the entity type parameter to setup the new comment


-----------------------------------------------------------------------
--  streams.files.tests -- Unit tests for buffered streams
--  Copyright (C) 2012, 2018, 2019, 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.Unbounded;
with Ada.Streams.Stream_IO;

with Util.Test_Caller;

with Util.Streams.Files;
with Util.Streams.Texts;
package body Util.Streams.Texts.Tests is

   use Ada.Streams.Stream_IO;
   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Open, Read_Line, Close",
                       Test_Read_Line'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Write (Integer)",
                       Test_Write_Integer'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a text stream.
   --  ------------------------------
   procedure Test_Read_Line (T : in out Test) is
      Stream : aliased Files.File_Stream;
      Reader : Util.Streams.Texts.Reader_Stream;
      Count  : Natural := 0;
   begin
      Stream.Open (Name => "Makefile", Mode => In_File);
      Reader.Initialize (From => Stream'Access);

      while not Reader.Is_Eof loop
         declare
            Line : Ada.Strings.Unbounded.Unbounded_String;
         begin
            Reader.Read_Line (Line);
            Count := Count + 1;
         end;
      end loop;
      Stream.Close;
      T.Assert (Count > 100, "Too few lines read");
   end Test_Read_Line;

   --  ------------------------------
   --  Write on a text stream converting an integer and writing it.
   --  ------------------------------
   procedure Test_Write_Integer (T : in out Test) is
      Stream  : Print_Stream;
      Buf     : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Stream.Initialize (Size => 4);

      --  Write '0' (we don't want the Ada spurious space).
      Stream.Write (Integer (0));

      Assert_Equals (T, 1, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 1, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "0", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '1234'
      Stream.Write (Integer (1234));

      Assert_Equals (T, 4, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 4, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "1234", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '-234'
      Stream.Write (Integer (-234));

      Assert_Equals (T, 4, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 4, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "-234", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");
   end Test_Write_Integer;

end Util.Streams.Texts.Tests;

-----------------------------------------------------------------------
--  streams.files.tests -- Unit tests for buffered streams
--  Copyright (C) 2012, 2018, 2019, 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.Unbounded;
with Ada.Streams.Stream_IO;

with Util.Test_Caller;

with Util.Streams.Files;
with Util.Streams.Texts;
package body Util.Streams.Texts.Tests is

   use Ada.Streams.Stream_IO;
   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Open, Read_Line, Close",
                       Test_Read_Line'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Write (Integer)",
                       Test_Write_Integer'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Write (Long_Long_Integer)",
                       Test_Write_Long_Integer'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a text stream.
   --  ------------------------------
   procedure Test_Read_Line (T : in out Test) is
      Stream : aliased Files.File_Stream;
      Reader : Util.Streams.Texts.Reader_Stream;
      Count  : Natural := 0;
   begin
      Stream.Open (Name => "Makefile", Mode => In_File);
      Reader.Initialize (From => Stream'Access);

      while not Reader.Is_Eof loop
         declare
            Line : Ada.Strings.Unbounded.Unbounded_String;
         begin
            Reader.Read_Line (Line);
            Count := Count + 1;
         end;
      end loop;
      Stream.Close;
      T.Assert (Count > 100, "Too few lines read");
   end Test_Read_Line;

   --  ------------------------------
   --  Write on a text stream converting an integer and writing it.
   --  ------------------------------
   procedure Test_Write_Integer (T : in out Test) is
      Stream  : Print_Stream;
      Buf     : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Stream.Initialize (Size => 4);

      --  Write '0' (we don't want the Ada spurious space).
      Stream.Write (Integer (0));

      Assert_Equals (T, 1, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 1, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "0", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '1234'
      Stream.Write (Integer (1234));

      Assert_Equals (T, 4, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 4, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "1234", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '-234'
      Stream.Write (Integer (-234));

      Assert_Equals (T, 4, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 4, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "-234", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");
   end Test_Write_Integer;

   --  ------------------------------
   --  Write on a text stream converting an integer and writing it.
   --  ------------------------------
   procedure Test_Write_Long_Integer (T : in out Test) is
      Stream  : Print_Stream;
      Buf     : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Stream.Initialize (Size => 64);

      --  Write '0' (we don't want the Ada spurious space).
      Stream.Write (Long_Long_Integer (0));

      Assert_Equals (T, 1, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 1, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "0", Ada.Strings.Unbounded.To_String (Buf), "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '1234'
      Stream.Write (Long_Long_Integer (123456789012345));

      Assert_Equals (T, 15, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 15, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "123456789012345", Ada.Strings.Unbounded.To_String (Buf),
                     "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");

      --  Write '-2345678901234'
      Stream.Write (Long_Long_Integer (-2345678901234));

      Assert_Equals (T, 14, Integer (Stream.Get_Size), "Invalid size for stream");

      Stream.Flush (Buf);
      Assert_Equals (T, 14, Ada.Strings.Unbounded.Length (Buf), "Invalid size for string");

      Assert_Equals (T, "-2345678901234", Ada.Strings.Unbounded.To_String (Buf),
                     "Invalid stream content");

      Assert_Equals (T, 0, Integer (Stream.Get_Size), "Invalid size for stream after Flush");
   end Test_Write_Long_Integer;

end Util.Streams.Texts.Tests;

Implement Test_Write_Long_Integer and register the new test for execution


------------------------------------------------------------------------------
--                                                                          --
--                     Copyright (C) 2015-2017, AdaCore                     --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with HAL;             use HAL;
with HAL.Framebuffer; use HAL.Framebuffer;
with HAL.Bitmap;

with Framebuffer_DSI;

private with STM32.Device;
private with STM32.DMA2D_Bitmap;
private with STM32.DSI;
private with STM32.GPIO;

package Framebuffer_OTM8009A is

   LCD_Natural_Width  : constant := Framebuffer_DSI.LCD_Natural_Width;
   LCD_Natural_Height : constant := Framebuffer_DSI.LCD_Natural_Width;

   type Frame_Buffer is limited
     new HAL.Framebuffer.Frame_Buffer_Display with private;

   procedure Initialize
     (Display     : in out Frame_Buffer;
      Orientation : HAL.Framebuffer.Display_Orientation := Default;
      Mode        : HAL.Framebuffer.Wait_Mode := Interrupt);

private

   DSI_RESET   : STM32.GPIO.GPIO_Point renames STM32.Device.PH7;

   PLLSAIN     : constant := 417;
   PLLSAIR     : constant := 5;
   PLLSAI_DIVR : constant := 2;
   PLL_N_Div   : constant := 125;
   PLL_IN_Div  : constant STM32.DSI.DSI_PLL_IDF := STM32.DSI.PLL_IN_DIV2;
   PLL_OUT_Div : constant STM32.DSI.DSI_PLL_ODF := STM32.DSI.PLL_OUT_DIV1;

   type Frame_Buffer is limited new Framebuffer_DSI.Frame_Buffer
     with null record;

end Framebuffer_OTM8009A;

------------------------------------------------------------------------------
--                                                                          --
--                     Copyright (C) 2015-2017, AdaCore                     --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with HAL;             use HAL;
with HAL.Framebuffer; use HAL.Framebuffer;
with HAL.Bitmap;

with Framebuffer_DSI;

private with STM32.Device;
private with STM32.DMA2D_Bitmap;
private with STM32.DSI;
private with STM32.GPIO;

package Framebuffer_OTM8009A is

   LCD_Natural_Width  : constant := Framebuffer_DSI.LCD_Natural_Width;
   LCD_Natural_Height : constant := Framebuffer_DSI.LCD_Natural_Height;

   type Frame_Buffer is limited
     new HAL.Framebuffer.Frame_Buffer_Display with private;

   procedure Initialize
     (Display     : in out Frame_Buffer;
      Orientation : HAL.Framebuffer.Display_Orientation := Default;
      Mode        : HAL.Framebuffer.Wait_Mode := Interrupt);

private

   DSI_RESET   : STM32.GPIO.GPIO_Point renames STM32.Device.PH7;

   PLLSAIN     : constant := 417;
   PLLSAIR     : constant := 5;
   PLLSAI_DIVR : constant := 2;
   PLL_N_Div   : constant := 125;
   PLL_IN_Div  : constant STM32.DSI.DSI_PLL_IDF := STM32.DSI.PLL_IN_DIV2;
   PLL_OUT_Div : constant STM32.DSI.DSI_PLL_ODF := STM32.DSI.PLL_OUT_DIV1;

   type Frame_Buffer is limited new Framebuffer_DSI.Frame_Buffer
     with null record;

end Framebuffer_OTM8009A;

Fix Typo in screen Height

framebuffer_otm8009a: Fix Typo in screen Height


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

with Util.Tests;

package Security.Permissions.Tests is

   package P_Admin is new Permissions.Definition ("admin");
   package P_Create is new Permissions.Definition ("create");
   package P_Update is new Permissions.Definition ("update");
   package P_Delete is new Permissions.Definition ("delete");

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

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

   --  Test Add_Permission and Get_Permission_Index
   procedure Test_Add_Permission (T : in out Test);

   --  Test the permission created by the Definition package.
   procedure Test_Define_Permission (T : in out Test);

   --  Test Get_Permission on invalid permission name.
   procedure Test_Get_Invalid_Permission (T : in out Test);

end Security.Permissions.Tests;

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

with Util.Tests;

package Security.Permissions.Tests is

   package P_Admin is new Permissions.Definition ("admin");
   package P_Create is new Permissions.Definition ("create");
   package P_Update is new Permissions.Definition ("update");
   package P_Delete is new Permissions.Definition ("delete");

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

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

   --  Test Add_Permission and Get_Permission_Index.
   procedure Test_Add_Permission (T : in out Test);

   --  Test the permission created by the Definition package.
   procedure Test_Define_Permission (T : in out Test);

   --  Test Get_Permission on invalid permission name.
   procedure Test_Get_Invalid_Permission (T : in out Test);

   --  Test operations on the Permission_Index_Set.
   procedure Test_Add_Permission_Set (T : in out Test);

end Security.Permissions.Tests;

Declare the Test_Add_Permission_Set unit test


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

with Ada.Finalization;

with Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Beans.Objects.Maps;

with ASF.Applications;

with ADO.Sessions;

with AWA.Events;
with AWA.Jobs.Models;

package AWA.Jobs.Services is

   Closed_Error  : exception;

   Schedule_Error : exception;

   Invalid_Value : exception;

   --  Event posted when a job is created.
   package Job_Create_Event is new AWA.Events.Definition (Name => "job-create");

   --  ------------------------------
   --  Abstract_Job Type
   --  ------------------------------
   --  The Abstract_Job_Type is an abstract tagged record which defines a job that can be
   --  scheduled and executed.
   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Abstract_Job_Access is access all Abstract_Job_Type'Class;

   --  ------------------------------
   --  Job Factory
   --  ------------------------------
   type Job_Factory is abstract tagged limited null record;
   type Job_Factory_Access is access all Job_Factory'Class;

   --  Create the job instance using the job factory.
   function Create (Factory : in Job_Factory) return Abstract_Job_Access is abstract;

   --  Get the job factory name.
   function Get_Name (Factory : in Job_Factory'Class) return String;

   --  Execute the job.  This operation must be implemented and should perform the work
   --  represented by the job.  It should use the <tt>Get_Parameter</tt> function to retrieve
   --  the job parameter and it can use the <tt>Set_Result</tt> operation to save the result.
   procedure Execute (Job : in out Abstract_Job_Type) is abstract;

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String);

   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object);

   --  Get the job parameter identified by the Name and convert the value into a string.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String;

   --  Get the job parameter identified by the Name and return it as a typed object.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object;

   --  Get the job status.
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type;

   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type);

   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class);

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class);

   --  ------------------------------
   --  Work Factory
   --  ------------------------------
   type Work_Access is access procedure (Job : in out Abstract_Job_Type'Class);

   type Work_Factory (Work : Work_Access) is new Job_Factory with null record;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access;

   --  ------------------------------
   --
   --  ------------------------------
   type Job_Type is new Abstract_Job_Type with private;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class);

   procedure Execute (Job : in out Job_Type);

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   generic
      type T is new Abstract_Job_Type with private;
   package Definition is
      type Job_Type_Factory is new Job_Factory with null record;

      overriding
      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access;

      Factory : aliased Job_Type_Factory;

   end Definition;

   generic
      Work : in Work_Access;
   package Work_Definition is
      type S_Factory is new Work_Factory with null record;

      Factory : aliased S_Factory := S_Factory '(Work => Work);
   end Work_Definition;

private

   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Job              : AWA.Jobs.Models.Job_Ref;
      Props            : Util.Beans.Objects.Maps.Map;
      Results          : Util.Beans.Objects.Maps.Map;
      Props_Modified   : Boolean := False;
      Results_Modified : Boolean := False;
   end record;

   type Job_Type is new Abstract_Job_Type with record
      Work : Work_Access;
   end record;

end AWA.Jobs.Services;

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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Maps;

with ADO.Sessions;

with AWA.Events;
with AWA.Jobs.Models;

package AWA.Jobs.Services is

   Closed_Error  : exception;

   Schedule_Error : exception;

   Invalid_Value : exception;

   --  Event posted when a job is created.
   package Job_Create_Event is new AWA.Events.Definition (Name => "job-create");

   --  ------------------------------
   --  Abstract_Job Type
   --  ------------------------------
   --  The Abstract_Job_Type is an abstract tagged record which defines a job that can be
   --  scheduled and executed.
   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with private;
   type Abstract_Job_Access is access all Abstract_Job_Type'Class;

   --  ------------------------------
   --  Job Factory
   --  ------------------------------
   type Job_Factory is abstract tagged limited null record;
   type Job_Factory_Access is access all Job_Factory'Class;

   --  Create the job instance using the job factory.
   function Create (Factory : in Job_Factory) return Abstract_Job_Access is abstract;

   --  Get the job factory name.
   function Get_Name (Factory : in Job_Factory'Class) return String;

   --  Execute the job.  This operation must be implemented and should perform the work
   --  represented by the job.  It should use the <tt>Get_Parameter</tt> function to retrieve
   --  the job parameter and it can use the <tt>Set_Result</tt> operation to save the result.
   procedure Execute (Job : in out Abstract_Job_Type) is abstract;

   --  Set the job parameter identified by the Name to the value given in Value.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String);

   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object);

   --  Get the job parameter identified by the Name and convert the value into a string.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String;

   --  Get the job parameter identified by the Name and return it as a typed object.
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object;

   --  Get the job status.
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type;

   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type);

   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class);

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class);

   --  ------------------------------
   --  Work Factory
   --  ------------------------------
   type Work_Access is access procedure (Job : in out Abstract_Job_Type'Class);

   type Work_Factory (Work : Work_Access) is new Job_Factory with null record;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access;

   --  ------------------------------
   --
   --  ------------------------------
   type Job_Type is new Abstract_Job_Type with private;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class);

   procedure Execute (Job : in out Job_Type);

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   generic
      type T is new Abstract_Job_Type with private;
   package Definition is
      type Job_Type_Factory is new Job_Factory with null record;

      overriding
      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access;

      Factory : aliased Job_Type_Factory;

   end Definition;

   generic
      Work : in Work_Access;
   package Work_Definition is
      type S_Factory is new Work_Factory with null record;

      Factory : aliased S_Factory := S_Factory '(Work => Work);
   end Work_Definition;

private

   type Abstract_Job_Type is abstract new Ada.Finalization.Limited_Controlled with record
      Job              : AWA.Jobs.Models.Job_Ref;
      Props            : Util.Beans.Objects.Maps.Map;
      Results          : Util.Beans.Objects.Maps.Map;
      Props_Modified   : Boolean := False;
      Results_Modified : Boolean := False;
   end record;

   type Job_Type is new Abstract_Job_Type with record
      Work : Work_Access;
   end record;

end AWA.Jobs.Services;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  util-commands-parsers.gnat_parser -- GNAT command line parser for command drivers
--  Copyright (C) 2018, 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 GNAT.OS_Lib;

package body Util.Commands.Parsers.GNAT_Parser is

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access;

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access is
      Count   : constant Natural := Args.Get_Count;
      New_Arg : GNAT.OS_Lib.Argument_List (1 .. Count);
   begin
      for I in 1 .. Count loop
         New_Arg (I) := new String '(Args.Get_Argument (I));
      end loop;
      return new GNAT.OS_Lib.Argument_List '(New_Arg);
   end To_OS_Lib_Argument_List;

   --  ------------------------------
   --  Get all the remaining arguments from the GNAT command line parse.
   --  ------------------------------
   procedure Get_Arguments (List    : in out Dynamic_Argument_List;
                            Command : in String;
                            Parser  : in GC.Opt_Parser := GC.Command_Line_Parser) is
   begin
      List.Name := Ada.Strings.Unbounded.To_Unbounded_String (Command);
      loop
         declare
            S : constant String := GC.Get_Argument (Parser => Parser);
         begin
            exit when S'Length = 0;
            List.List.Append (S);
         end;
      end loop;
   end Get_Arguments;

   procedure Execute (Config : in out Config_Type;
                      Args   : in Util.Commands.Argument_List'Class;
                      Process : access procedure (Cmd_Args : in Commands.Argument_List'Class)) is
      use type GC.Command_Line_Configuration;

      Empty    : Config_Type;
   begin
      if Config /= Empty then
         declare
            Parser   : GC.Opt_Parser;
            Cmd_Args : Dynamic_Argument_List;
            Params   : GNAT.OS_Lib.Argument_List_Access
              := To_OS_Lib_Argument_List (Args);
         begin
            GC.Initialize_Option_Scan (Parser, Params);
            GC.Getopt (Config => Config, Parser => Parser);
            Get_Arguments (Cmd_Args, Args.Get_Command_Name, Parser);
            Process (Cmd_Args);
            GC.Free (Config);
            GNAT.OS_Lib.Free (Params);

         exception
            when others =>
               GNAT.OS_Lib.Free (Params);
               GC.Free (Config);
               raise;
         end;
      else
         Process (Args);
      end if;
   end Execute;

   procedure Usage (Name   : in String;
                    Config : in out Config_Type) is
   begin
      GC.Set_Usage (Config, Usage => Name & " [switches] [arguments]");
      GC.Display_Help (Config);
   end Usage;

end Util.Commands.Parsers.GNAT_Parser;

-----------------------------------------------------------------------
--  util-commands-parsers.gnat_parser -- GNAT command line parser for command drivers
--  Copyright (C) 2018, 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 GNAT.OS_Lib;

package body Util.Commands.Parsers.GNAT_Parser is

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access;

   function To_OS_Lib_Argument_List (Args : in Argument_List'Class)
                                     return GNAT.OS_Lib.Argument_List_Access is
      Count   : constant Natural := Args.Get_Count;
      New_Arg : GNAT.OS_Lib.Argument_List (1 .. Count);
   begin
      for I in 1 .. Count loop
         New_Arg (I) := new String '(Args.Get_Argument (I));
      end loop;
      return new GNAT.OS_Lib.Argument_List '(New_Arg);
   end To_OS_Lib_Argument_List;

   --  ------------------------------
   --  Get all the remaining arguments from the GNAT command line parse.
   --  ------------------------------
   procedure Get_Arguments (List    : in out Dynamic_Argument_List;
                            Command : in String;
                            Parser  : in GC.Opt_Parser := GC.Command_Line_Parser) is
   begin
      List.Name := Ada.Strings.Unbounded.To_Unbounded_String (Command);
      loop
         declare
            S : constant String := GC.Get_Argument (Parser => Parser);
         begin
            exit when S'Length = 0;
            List.List.Append (S);
         end;
      end loop;
   end Get_Arguments;

   procedure Execute (Config : in out Config_Type;
                      Args   : in Util.Commands.Argument_List'Class;
                      Process : access procedure (Cmd_Args : in Commands.Argument_List'Class)) is
      use type GC.Command_Line_Configuration;

      Empty    : Config_Type;
   begin
      if Config /= Empty then
         declare
            Parser   : GC.Opt_Parser;
            Cmd_Args : Dynamic_Argument_List;
            Params   : GNAT.OS_Lib.Argument_List_Access
              := To_OS_Lib_Argument_List (Args);
         begin
            GC.Initialize_Option_Scan (Parser, Params);
            GC.Getopt (Config => Config, Parser => Parser);
            Get_Arguments (Cmd_Args, Args.Get_Command_Name, Parser);
            Process (Cmd_Args);
            GC.Free (Config);
            GNAT.OS_Lib.Free (Params);

         exception
            when others =>
               GNAT.OS_Lib.Free (Params);
               GC.Free (Config);
               raise;
         end;
      else
         Process (Args);
      end if;
   end Execute;

   procedure Usage (Name   : in String;
                    Config : in out Config_Type) is
      Opts : constant String := GC.Get_Switches (Config);
   begin
      if Opts'Length > 0 then
         GC.Set_Usage (Config, Usage => Name & " [switches] [arguments]");
         GC.Display_Help (Config);
      end if;
   end Usage;

end Util.Commands.Parsers.GNAT_Parser;

Use Get_Switches to check that there are some switches on the config If there are no switch, don't call Display_Help because it will crash


-----------------------------------------------------------------------
--  util-log-appenders-rolling_files -- Rolling file log appenders
--  Copyright (C) 2022 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.Text_IO;
with Ada.Calendar;
with Util.Properties;
private with Util.Refs;
private with Util.Files.Rolling;

--  The `RollingFile` appender recognises the following configurations:
--
--  | Name           | Description                                                          |
--  | -------------- | --------------------------------------------------------------       |
--  | layout         | Defines the format of the message printed by the appender.           |
--  | level          | Defines the minimum level above which messages are printed.          |
--  | fileName       | The name of the file to write to. If the file, or any of its parent  |
--  |                | directories, do not exist, they will be created.                     |
--  | filePattern    | The pattern of the file name of the archived log file.  The pattern  |
--  |                | can contain '%i' which are replaced by a counter incremented at each |
--  |                | rollover, a '%d' is replaced by a date pattern.                      |
--  | append         | When 'true' or '1', the file is opened in append mode otherwise      |
--  |                | it is truncated (the default is to truncate).                        |
--  | immediateFlush | When 'true' or '1', the file is flushed after each message log.      |
--  |                | Immediate flush is useful in some situations to have the log file    |
--  |                | updated immediately at the expense of slowing down the processing    |
--  |                | of logs.                                                             |
--  | policy         | The triggering policy which drives when a rolling is performed.      |
--  |                | Possible values are: `none`, `size`, `time`                          |
--  | strategy       | The strategy to use to determine the name and location of the        |
--  |                | archive file.  Possible values are: `ascending`, `descending`, and   |
--  |                | `direct`.  Default is `ascending`.                                   |
--  | policyInterval | How often a rollover should occur based on the most specific time    |
--  |                | unit in the date pattern. For example, with a date pattern with      |
--  |                | hours as the most specific item and and increment of 4 rollovers     |
--  |                | would occur every 4 hours. The default value is 1.                   |
--  | policyMin      | The minimum value of the counter. The default value is 1.            |
--  | policyMax      | The maximum value of the counter. Once this values is reached older  |
--  |                | archives will be deleted on subsequent rollovers. The default        |
--  |                | value is 7.                                                          |
--  | minSize        | The minimum size the file must have to roll over.                    |
package Util.Log.Appenders.Rolling_Files is

   --  ------------------------------
   --  File appender
   --  ------------------------------
   type File_Appender (Length : Positive) is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

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

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
     return Appender_Access;

private

   type File_Entity is new Util.Refs.Ref_Entity with record
      Output          : Ada.Text_IO.File_Type;
   end record;
   type File_Access is access all File_Entity;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out File_Entity);

   package File_Refs is new Util.Refs.References (File_Entity, File_Access);

   protected type Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager);

      procedure Openlog (File : out File_Refs.Ref);

      procedure Flush (File : out File_Refs.Ref);

      procedure Closelog;

   private
      Manager    : Util.Files.Rolling.File_Manager;
      Current    : File_Refs.Ref;
      Append     : Boolean;
   end Rolling_File;

   type File_Appender (Length : Positive) is new Appender (Length) with record
      Immediate_Flush : Boolean := False;
      File            : Rolling_File;
   end record;

end Util.Log.Appenders.Rolling_Files;

-----------------------------------------------------------------------
--  util-log-appenders-rolling_files -- Rolling file log appenders
--  Copyright (C) 2022 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.Text_IO;
with Ada.Calendar;
with Util.Properties;
private with Util.Refs;
private with Util.Files.Rolling;

--  === Rolling file appender ===
--  The `RollingFile` appender recognises the following configurations:
--
--  | Name           | Description                                                          |
--  | -------------- | --------------------------------------------------------------       |
--  | layout         | Defines the format of the message printed by the appender.           |
--  | level          | Defines the minimum level above which messages are printed.          |
--  | fileName       | The name of the file to write to. If the file, or any of its parent  |
--  |                | directories, do not exist, they will be created.                     |
--  | filePattern    | The pattern of the file name of the archived log file.  The pattern  |
--  |                | can contain '%i' which are replaced by a counter incremented at each |
--  |                | rollover, a '%d' is replaced by a date pattern.                      |
--  | append         | When 'true' or '1', the file is opened in append mode otherwise      |
--  |                | it is truncated (the default is to truncate).                        |
--  | immediateFlush | When 'true' or '1', the file is flushed after each message log.      |
--  |                | Immediate flush is useful in some situations to have the log file    |
--  |                | updated immediately at the expense of slowing down the processing    |
--  |                | of logs.                                                             |
--  | policy         | The triggering policy which drives when a rolling is performed.      |
--  |                | Possible values are: `none`, `size`, `time`                          |
--  | strategy       | The strategy to use to determine the name and location of the        |
--  |                | archive file.  Possible values are: `ascending`, `descending`, and   |
--  |                | `direct`.  Default is `ascending`.                                   |
--  | policyInterval | How often a rollover should occur based on the most specific time    |
--  |                | unit in the date pattern. For example, with a date pattern with      |
--  |                | hours as the most specific item and and increment of 4 rollovers     |
--  |                | would occur every 4 hours. The default value is 1.                   |
--  | policyMin      | The minimum value of the counter. The default value is 1.            |
--  | policyMax      | The maximum value of the counter. Once this values is reached older  |
--  |                | archives will be deleted on subsequent rollovers. The default        |
--  |                | value is 7.                                                          |
--  | minSize        | The minimum size the file must have to roll over.                    |
package Util.Log.Appenders.Rolling_Files is

   --  ------------------------------
   --  File appender
   --  ------------------------------
   type File_Appender (Length : Positive) is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

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

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create (Name       : in String;
                    Properties : in Util.Properties.Manager;
                    Default    : in Level_Type)
     return Appender_Access;

private

   type File_Entity is new Util.Refs.Ref_Entity with record
      Output          : Ada.Text_IO.File_Type;
   end record;
   type File_Access is access all File_Entity;

   --  Finalize the referenced object.  This is called before the object is freed.
   overriding
   procedure Finalize (Object : in out File_Entity);

   package File_Refs is new Util.Refs.References (File_Entity, File_Access);

   protected type Rolling_File is

      procedure Initialize (Name       : in String;
                            Base       : in String;
                            Properties : in Util.Properties.Manager);

      procedure Openlog (File : out File_Refs.Ref);

      procedure Flush (File : out File_Refs.Ref);

      procedure Closelog;

   private
      Manager    : Util.Files.Rolling.File_Manager;
      Current    : File_Refs.Ref;
      Append     : Boolean;
   end Rolling_File;

   type File_Appender (Length : Positive) is new Appender (Length) with record
      Immediate_Flush : Boolean := False;
      File            : Rolling_File;
   end record;

end Util.Log.Appenders.Rolling_Files;

Add documentation for the configuration

Add documentation for the configuration


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

with AWS.Headers;
with AWS.Messages;
with AWS.Response.Set;
with AWS.Containers.Tables;
package body ASF.Responses.Web is

   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (Size   => 256 * 1024,
                               Output => Resp'Unchecked_Access,
                               Input  => null);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   procedure Write (Stream : in out Response;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      AWS.Response.Set.Append_Body (D    => Stream.Data,
                                    Item => Buffer);
   end Write;

   --  ------------------------------
   --  Flush the buffer (if any) to the sink.
   --  ------------------------------
   procedure Flush (Stream : in out Response) is
   begin
      null;
   end Flush;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code is
      use AWS.Messages;
   begin
      case Status is
         when 100 =>
            return S100;
         when 101 =>
            return S101;
         when 200 =>
            return S200;
         when 201 =>
            return S201;
         when 202 =>
            return S202;
         when 301 =>
            return S301;
         when 302 =>
            return S302;
         when 400 =>
            return S400;
         when 401 =>
            return S401;
         when 402 =>
            return S402;
         when 403 =>
            return S403;
         when 404 =>
            return S404;
         when others =>
            return S500;
      end case;
   end To_Status_Code;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Headers : constant AWS.Headers.List := AWS.Response.Header (Resp.Data);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (Headers),
                                           ";", Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if AWS.Response.Header (Resp.Data, Name)'Length = 0 then
         AWS.Response.Set.Add_Header (D     => Resp.Data,
                                      Name  => Name,
                                      Value => Value);
      end if;
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Response.Set.Add_Header (D     => Resp.Data,
                                   Name  => Name,
                                   Value => Value);
   end Add_Header;

   --  ------------------------------
   --  Sends a temporary redirect response to the client using the specified redirect
   --  location URL. This method can accept relative URLs; the servlet container must
   --  convert the relative URL to an absolute URL before sending the response to the
   --  client. If the location is relative without a leading '/' the container
   --  interprets it as relative to the current request URI. If the location is relative
   --  with a leading '/' the container interprets it as relative to the servlet
   --  container root.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   --  ------------------------------
   procedure Send_Redirect (Resp     : in out Response;
                            Location : in String) is
   begin
      Response'Class (Resp).Set_Status (SC_FOUND);
      Response'Class (Resp).Set_Header (Name  => "Location",
                                        Value => Location);
      Resp.Redirect := True;
   end Send_Redirect;

   --  ------------------------------
   --  Prepare the response data by collecting the status, content type and message body.
   --  ------------------------------
   procedure Build (Resp : in out Response) is
   begin
      if not Resp.Redirect then
         AWS.Response.Set.Content_Type (D     => Resp.Data,
                                        Value => Resp.Get_Content_Type);
         Resp.Content.Flush;
         if AWS.Response.Is_Empty (Resp.Data) then
            AWS.Response.Set.Message_Body (Resp.Data, "");
         end if;
      else
         AWS.Response.Set.Mode (D     => Resp.Data,
                                Value => AWS.Response.Header);
      end if;
      AWS.Response.Set.Status_Code (D     => Resp.Data,
                                    Value => To_Status_Code (Resp.Get_Status));
   end Build;

   --  ------------------------------
   --  Get the response data
   --  ------------------------------
   function Get_Data (Resp : in Response) return AWS.Response.Data is
   begin
      return Resp.Data;
   end Get_Data;

end ASF.Responses.Web;

-----------------------------------------------------------------------
--  asf.responses.web -- ASF Responses with AWS server
--  Copyright (C) 2009, 2010, 2011, 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 AWS.Headers;
with AWS.Messages;
with AWS.Response.Set;
with AWS.Containers.Tables;
package body ASF.Responses.Web is

   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (Size   => 256 * 1024,
                               Output => Resp'Unchecked_Access);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   procedure Write (Stream : in out Response;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      AWS.Response.Set.Append_Body (D    => Stream.Data,
                                    Item => Buffer);
   end Write;

   --  ------------------------------
   --  Flush the buffer (if any) to the sink.
   --  ------------------------------
   procedure Flush (Stream : in out Response) is
   begin
      null;
   end Flush;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code is
      use AWS.Messages;
   begin
      case Status is
         when 100 =>
            return S100;
         when 101 =>
            return S101;
         when 200 =>
            return S200;
         when 201 =>
            return S201;
         when 202 =>
            return S202;
         when 301 =>
            return S301;
         when 302 =>
            return S302;
         when 400 =>
            return S400;
         when 401 =>
            return S401;
         when 402 =>
            return S402;
         when 403 =>
            return S403;
         when 404 =>
            return S404;
         when others =>
            return S500;
      end case;
   end To_Status_Code;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Headers : constant AWS.Headers.List := AWS.Response.Header (Resp.Data);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (Headers),
                                           ";", Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if AWS.Response.Header (Resp.Data, Name)'Length = 0 then
         AWS.Response.Set.Add_Header (D     => Resp.Data,
                                      Name  => Name,
                                      Value => Value);
      end if;
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Response.Set.Add_Header (D     => Resp.Data,
                                   Name  => Name,
                                   Value => Value);
   end Add_Header;

   --  ------------------------------
   --  Sends a temporary redirect response to the client using the specified redirect
   --  location URL. This method can accept relative URLs; the servlet container must
   --  convert the relative URL to an absolute URL before sending the response to the
   --  client. If the location is relative without a leading '/' the container
   --  interprets it as relative to the current request URI. If the location is relative
   --  with a leading '/' the container interprets it as relative to the servlet
   --  container root.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   --  ------------------------------
   procedure Send_Redirect (Resp     : in out Response;
                            Location : in String) is
   begin
      Response'Class (Resp).Set_Status (SC_FOUND);
      Response'Class (Resp).Set_Header (Name  => "Location",
                                        Value => Location);
      Resp.Redirect := True;
   end Send_Redirect;

   --  ------------------------------
   --  Prepare the response data by collecting the status, content type and message body.
   --  ------------------------------
   procedure Build (Resp : in out Response) is
   begin
      if not Resp.Redirect then
         AWS.Response.Set.Content_Type (D     => Resp.Data,
                                        Value => Resp.Get_Content_Type);
         Resp.Content.Flush;
         if AWS.Response.Is_Empty (Resp.Data) then
            AWS.Response.Set.Message_Body (Resp.Data, "");
         end if;
      else
         AWS.Response.Set.Mode (D     => Resp.Data,
                                Value => AWS.Response.Header);
      end if;
      AWS.Response.Set.Status_Code (D     => Resp.Data,
                                    Value => To_Status_Code (Resp.Get_Status));
   end Build;

   --  ------------------------------
   --  Get the response data
   --  ------------------------------
   function Get_Data (Resp : in Response) return AWS.Response.Data is
   begin
      return Resp.Data;
   end Get_Data;

end ASF.Responses.Web;

Update initialization of the output stream


-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  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 Util.Log.Loggers;

with ELF;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

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

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Id          : in MAT.Events.Targets.Probe_Index_Type;
                          Defs        : in MAT.Events.Attribute_Table;
                          Msg         : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size       := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path       := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Id    : in MAT.Events.Targets.Probe_Index_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Heap  : MAT.Memory.Region_Info;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

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

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               Region.Path := Path;
               Probe.Target.Process.Memory.Add_Region (Region);
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.Targets.MSG_BEGIN then
         Probe.Probe_Begin (Event.Index, Params.all, Msg);
      elsif Event.Index = MAT.Events.Targets.MSG_LIBRARY then
         Probe.Probe_Library (Event.Index, Params.all, Msg);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.Targets.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.Targets.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.Targets.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  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 Util.Log.Loggers;

with ELF;
with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

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

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;
   M_LIBNAME     : constant MAT.Events.Internal_Reference := 6;
   M_LADDR       : constant MAT.Events.Internal_Reference := 7;
   M_COUNT       : constant MAT.Events.Internal_Reference := 8;
   M_TYPE        : constant MAT.Events.Internal_Reference := 9;
   M_VADDR       : constant MAT.Events.Internal_Reference := 10;
   M_SIZE        : constant MAT.Events.Internal_Reference := 11;
   M_FLAGS       : constant MAT.Events.Internal_Reference := 12;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";
   LIBNAME_NAME  : aliased constant String := "libname";
   LADDR_NAME    : aliased constant String := "laddr";
   COUNT_NAME    : aliased constant String := "count";
   TYPE_NAME     : aliased constant String := "type";
   VADDR_NAME    : aliased constant String := "vaddr";
   SIZE_NAME     : aliased constant String := "size";
   FLAGS_NAME    : aliased constant String := "flags";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   Library_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => LIBNAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_LIBNAME),
      2 => (Name => LADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_LADDR),
      3 => (Name => COUNT_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_COUNT),
      4 => (Name => TYPE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_TYPE),
      5 => (Name => VADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_VADDR),
      6 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_SIZE),
      7 => (Name => FLAGS_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FLAGS));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Defs  : in MAT.Events.Attribute_Table;
                          Msg   : in out MAT.Readers.Message;
                          Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Process_Ref (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size  := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path  := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Event.Addr := Heap.Start_Addr;
      Event.Size := Heap.Size;
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   --  ------------------------------
   --  Extract the information from the 'library' event.
   --  ------------------------------
   procedure Probe_Library (Probe : in Process_Probe_Type;
                            Defs  : in MAT.Events.Attribute_Table;
                            Msg   : in out MAT.Readers.Message;
                            Event : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Types.Target_Addr;

      Count : MAT.Types.Target_Size := 0;
      Path  : Ada.Strings.Unbounded.Unbounded_String;
      Heap  : MAT.Memory.Region_Info;
      Addr  : MAT.Types.Target_Addr;
      Pos   : Natural := Defs'Last + 1;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_COUNT =>
                  Count := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);
                  Pos := I + 1;
                  exit;

               when M_LIBNAME =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_LADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Event.Addr := Addr;
      Event.Size := 0;
      for Region in 1 .. Count loop
         declare
            Region : MAT.Memory.Region_Info;
            Kind   : ELF.Elf32_Word := 0;
         begin
            for I in Pos .. Defs'Last loop
               declare
                  Def : MAT.Events.Attribute renames Defs (I);
               begin
                  case Def.Ref is
                  when M_SIZE =>
                     Region.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

                  when M_VADDR =>
                     Region.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

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

                  when M_FLAGS =>
                     Region.Flags := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

                  when others =>
                     MAT.Readers.Marshaller.Skip (Msg, Def.Size);
                  end case;
               end;
            end loop;
            if Kind = ELF.PT_LOAD then
               Region.Start_Addr := Addr + Region.Start_Addr;
               Region.End_Addr   := Region.Start_Addr + Region.Size;
               Region.Path := Path;
               Event.Size := Event.Size + Region.Size;
               Probe.Target.Process.Memory.Add_Region (Region);
            end if;
         end;
      end loop;
   end Probe_Library;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MAT.Events.Targets.MSG_BEGIN then
         Probe.Probe_Begin (Params.all, Msg, Event);
      elsif Event.Index = MAT.Events.Targets.MSG_LIBRARY then
         Probe.Probe_Library (Params.all, Msg, Event);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MAT.Events.Targets.MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MAT.Events.Targets.MSG_END,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "shlib", MAT.Events.Targets.MSG_LIBRARY,
                           Library_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

Update the event associated with the begin and library event to keep track of the library mapped address and size in the event