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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   type Grant_Type is new Security.Principal with private;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Grant_Type) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Grant_Type is new Security.Principal with record
      Access_Token  : Ada.Strings.Unbounded.Unbounded_String;
      Refresh_Token : Ada.Strings.Unbounded.Unbounded_String;
      Id_Token      : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Declare the Grant_Type for a better representation of a grant returned during the OAuth authorization Declare the Get_Name function for Grant_Type


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

with Util.Tests;

package Util.Texts.Builders_Tests is

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

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

   --  Test the length operation.
   procedure Test_Length (T : in out Test);

   --  Test the append operation.
   procedure Test_Append (T : in out Test);

   --  Test the iterate operation.
   procedure Test_Iterate (T : in out Test);

   --  Test the clear operation.
   procedure Test_Clear (T : in out Test);

   --  Test the append and iterate performance.
   procedure Test_Perf (T : in out Test);

end Util.Texts.Builders_Tests;

-----------------------------------------------------------------------
--  util-texts-builders_tests -- Unit tests for text builders
--  Copyright (C) 2013, 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 Util.Texts.Builders_Tests is

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

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

   --  Test the length operation.
   procedure Test_Length (T : in out Test);

   --  Test the append operation.
   procedure Test_Append (T : in out Test);

   --  Test the iterate operation.
   procedure Test_Iterate (T : in out Test);

   --  Test the clear operation.
   procedure Test_Clear (T : in out Test);

   --  Test the tail operation.
   procedure Test_Tail (T : in out Test);

   --  Test the append and iterate performance.
   procedure Test_Perf (T : in out Test);

end Util.Texts.Builders_Tests;

Declare the Test_Tail procedure

Declare the Test_Tail procedure


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

   use Ada.Characters.Conversions;

   Value_Range : constant Long_Long_Integer := T'Pos (T'Last) - T'Pos (T'First) + 1;

   NAME        : aliased constant String := "Enum";

   Value_Type  : aliased constant Basic_Type := Basic_Type '(Name => NAME'Access);

   --  ------------------------------
   --  Create an object from the given value.
   --  ------------------------------
   function To_Object (Value : in T) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type   => TYPE_INTEGER,
                            Int_Value => Long_Long_Integer (T'Pos (Value))),
        Type_Def  => Value_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Convert the object into a value.
   --  Raises Constraint_Error if the object cannot be converter to the target type.
   --  ------------------------------
   function To_Value (Value : in EL.Objects.Object) return T is
   begin
      case Value.V.Of_Type is
         when TYPE_INTEGER =>
            if ROUND_VALUE then
               return T'Val (Value.V.Int_Value mod Value_Range);
            else
               return T'Val (Value.V.Int_Value);
            end if;

         when TYPE_BOOLEAN =>
            return T'Val (Boolean'Pos (Value.V.Bool_Value));

         when TYPE_FLOAT =>
            if ROUND_VALUE then
               return T'Val (To_Long_Long_Integer (Value) mod Value_Range);
            else
               return T'Val (To_Long_Long_Integer (Value));
            end if;

         when TYPE_STRING =>
            if Value.V.Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (Value.V.Proxy.String_Value.all);

         when TYPE_WIDE_STRING =>
            if Value.V.Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (To_String (Value.V.Proxy.Wide_String_Value.all));

         when TYPE_NULL =>
            raise Constraint_Error with "The object value is null";

         when TYPE_TIME =>
            raise Constraint_Error with "Cannot convert a date into a discrete type";

         when TYPE_BEAN =>
            raise Constraint_Error with "Cannot convert a bean into a discrete type";

      end case;
   end To_Value;

end EL.Objects.Enums;

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

   use Ada.Characters.Conversions;

   Value_Range : constant Long_Long_Integer := T'Pos (T'Last) - T'Pos (T'First) + 1;

   --  ------------------------------
   --  Integer Type
   --  ------------------------------
   type Enum_Type is new Int_Type with null record;

   --  Get the type name
   overriding
   function Get_Name (Type_Def : in Enum_Type) return String;

   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String;

   --  ------------------------------
   --  Get the type name
   --  ------------------------------
   overriding
   function Get_Name (Type_Def : Enum_Type) return String is
      pragma Unreferenced (Type_Def);
   begin
      return "Enum";
   end Get_Name;

   --  ------------------------------
   --  Convert the value into a string.
   --  ------------------------------
   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String is
      pragma Unreferenced (Type_Def);
   begin
      return T'Image (T'Val (Value.Int_Value));
   end To_String;

   Value_Type  : aliased constant Enum_Type := Enum_Type '(others => <>);

   --  ------------------------------
   --  Create an object from the given value.
   --  ------------------------------
   function To_Object (Value : in T) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type   => TYPE_INTEGER,
                            Int_Value => Long_Long_Integer (T'Pos (Value))),
        Type_Def  => Value_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Convert the object into a value.
   --  Raises Constraint_Error if the object cannot be converter to the target type.
   --  ------------------------------
   function To_Value (Value : in EL.Objects.Object) return T is
   begin
      case Value.V.Of_Type is
         when TYPE_INTEGER =>
            if ROUND_VALUE then
               return T'Val (Value.V.Int_Value mod Value_Range);
            else
               return T'Val (Value.V.Int_Value);
            end if;

         when TYPE_BOOLEAN =>
            return T'Val (Boolean'Pos (Value.V.Bool_Value));

         when TYPE_FLOAT =>
            if ROUND_VALUE then
               return T'Val (To_Long_Long_Integer (Value) mod Value_Range);
            else
               return T'Val (To_Long_Long_Integer (Value));
            end if;

         when TYPE_STRING =>
            if Value.V.Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (Value.V.Proxy.String_Value.all);

         when TYPE_WIDE_STRING =>
            if Value.V.Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (To_String (Value.V.Proxy.Wide_String_Value.all));

         when TYPE_NULL =>
            raise Constraint_Error with "The object value is null";

         when TYPE_TIME =>
            raise Constraint_Error with "Cannot convert a date into a discrete type";

         when TYPE_BEAN =>
            raise Constraint_Error with "Cannot convert a bean into a discrete type";

      end case;
   end To_Value;

end EL.Objects.Enums;

Implement the necessary functions for the enum type definition.


-----------------------------------------------------------------------
--  util-http-clients-mockups -- HTTP Clients
--  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.Files;
with Util.Http.Mockups;
package body Util.Http.Clients.Mockups is

   use Ada.Strings.Unbounded;

   Manager : aliased File_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Set the path of the file that contains the response for the next
   --  Do_Get and Do_Post calls.
   --  ------------------------------
   procedure Set_File (Path : in String) is
   begin
      Manager.File := To_Unbounded_String (Path);
   end Set_File;

   procedure Create (Manager  : in File_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new Util.Http.Mockups.Mockup_Request;
   end Create;

   procedure Do_Get (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Http, URI);

      Rep : constant Util.Http.Mockups.Mockup_Response_Access
        := new Util.Http.Mockups.Mockup_Response;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Reply.Delegate := Rep.all'Access;
      Util.Files.Read_File (Path     => To_String (Manager.File),
                            Into     => Content,
                            Max_Size => 100000);
      Rep.Set_Body (To_String (Content));
      Rep.Set_Status (SC_OK);
   end Do_Get;

   procedure Do_Post (Manager  : in File_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Data);
   begin
      Manager.Do_Get (Http, URI, Reply);
   end Do_Post;

end Util.Http.Clients.Mockups;

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

with Util.Files;
with Util.Http.Mockups;
package body Util.Http.Clients.Mockups is

   use Ada.Strings.Unbounded;

   Manager : aliased File_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Set the path of the file that contains the response for the next
   --  Do_Get and Do_Post calls.
   --  ------------------------------
   procedure Set_File (Path : in String) is
   begin
      Manager.File := To_Unbounded_String (Path);
   end Set_File;

   procedure Create (Manager  : in File_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new Util.Http.Mockups.Mockup_Request;
   end Create;

   overriding
   procedure Do_Get (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Http, URI);

      Rep : constant Util.Http.Mockups.Mockup_Response_Access
        := new Util.Http.Mockups.Mockup_Response;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Reply.Delegate := Rep.all'Access;
      Util.Files.Read_File (Path     => To_String (Manager.File),
                            Into     => Content,
                            Max_Size => 100000);
      Rep.Set_Body (To_String (Content));
      Rep.Set_Status (SC_OK);
   end Do_Get;

   overriding
   procedure Do_Post (Manager  : in File_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Data);
   begin
      Manager.Do_Get (Http, URI, Reply);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Data);
   begin
      Manager.Do_Get (Http, URI, Reply);
   end Do_Put;

end Util.Http.Clients.Mockups;

Implement the Do_Put procedure

Implement the Do_Put procedure


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 GL.Errors;
with GL.Debug.Logs;
with GL.Toggles;
with GL.Types;

with Orka.Loggers;
with Orka.Logging;

package body Orka.Debug is

   use GL.Debug;

   Has_Seen_API_Error : Boolean := False
     with Volatile => True;

   Debug_Synchronous : Boolean := False
     with Volatile => True;

   procedure Log_Debug_Message
     (From      : Source;
      Kind      : Message_Type;
      Level     : Severity;
      ID        : GL.Types.UInt;
      Message   : String)
   is
      use all type Orka.Loggers.Source;
      use all type Orka.Loggers.Severity;

      Source : constant Orka.Loggers.Source
        := (case From is
               when OpenGL          => OpenGL,
               when Window_System   => Window_System,
               when Shader_Compiler => Shader_Compiler,
               when Third_Party     => Third_Party,
               when Application     => Application,
               when Other           => Other);

      Severity : constant Orka.Loggers.Severity
        := (case Level is
               when High         => Loggers.Error,
               when Medium       => Loggers.Warning,
               when Low          => Loggers.Info,
               when Notification => Loggers.Debug);
   begin
      if Debug_Synchronous and then Has_Seen_API_Error then
         Has_Seen_API_Error := False;
         GL.Errors.Raise_Exception_On_OpenGL_Error;
      end if;

      Logging.Log (Source, Loggers.Message_Type (Kind), Severity, Natural (ID), Message);

      if Debug_Synchronous and then (Source = OpenGL and Kind = Error) then
         GL.Errors.Raise_Exception_On_OpenGL_Error;
         Has_Seen_API_Error := True;
      end if;
   end Log_Debug_Message;

   procedure Set_Log_Messages (Enable : Boolean; Raise_API_Error : Boolean := False) is
   begin
      if Enable then
         declare
            Count : constant Natural := Natural (GL.Debug.Logs.Logged_Messages);
         begin
            if Count > 0 then
               Log_Debug_Message (Application, Other, Notification, 0,
                 "Flushing" & Count'Image & " messages in the debug log:");
            end if;
         end;

         for M of GL.Debug.Logs.Message_Log loop
            Log_Debug_Message (M.From, M.Kind, M.Level, M.ID, M.Message.Element);
         end loop;

         GL.Toggles.Set (GL.Toggles.Debug_Output_Synchronous,
           (if Raise_API_Error then GL.Toggles.Enabled else GL.Toggles.Disabled));
         Debug_Synchronous := Raise_API_Error;

         GL.Toggles.Enable (GL.Toggles.Debug_Output);
         GL.Debug.Set_Message_Callback (Log_Debug_Message'Access);
         GL.Debug.Set (GL.Debug.Low, True);
      else
         GL.Toggles.Disable (GL.Toggles.Debug_Output);
         GL.Debug.Disable_Message_Callback;
      end if;
   end Set_Log_Messages;

end Orka.Debug;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 GL.Errors;
with GL.Debug.Logs;
with GL.Toggles;
with GL.Types;

with Orka.Loggers;
with Orka.Logging;

package body Orka.Debug is

   use GL.Debug;

   Has_Seen_API_Error : Boolean := False
     with Volatile => True;

   Debug_Synchronous : Boolean := False
     with Volatile => True;

   procedure Log_Debug_Message
     (From      : Source;
      Kind      : Message_Type;
      Level     : Severity;
      ID        : GL.Types.UInt;
      Message   : String)
   is
      use all type Orka.Loggers.Source;
      use all type Orka.Loggers.Severity;

      Source : constant Orka.Loggers.Source
        := (case From is
               when OpenGL          => OpenGL,
               when Window_System   => Window_System,
               when Shader_Compiler => Shader_Compiler,
               when Third_Party     => Third_Party,
               when Application     => Application,
               when Other           => Other);

      Severity : constant Orka.Loggers.Severity
        := (case Level is
               when High         => Loggers.Error,
               when Medium       => Loggers.Warning,
               when Low          => Loggers.Info,
               when Notification => Loggers.Debug);
   begin
      if Debug_Synchronous and then Has_Seen_API_Error then
         Has_Seen_API_Error := False;
         GL.Errors.Raise_Exception_On_OpenGL_Error;
      end if;

      Logging.Log (Source, Loggers.Message_Type (Kind), Severity, Natural (ID), Message);

      if Debug_Synchronous and then (Source = OpenGL and Kind = Error) then
         GL.Errors.Raise_Exception_On_OpenGL_Error;
         Has_Seen_API_Error := True;
      end if;
   end Log_Debug_Message;

   procedure Set_Log_Messages (Enable : Boolean; Raise_API_Error : Boolean := False) is
   begin
      if Enable then
         --  Enable synchronous output to prevent interleaving messages while
         --  flushing the log below
         GL.Toggles.Enable (GL.Toggles.Debug_Output_Synchronous);
         Debug_Synchronous := Raise_API_Error;

         GL.Toggles.Enable (GL.Toggles.Debug_Output);
         GL.Debug.Set_Message_Callback (Log_Debug_Message'Access);
         GL.Debug.Set (GL.Debug.Low, True);

         --  At this point, a callback has been set, which guarantees that no
         --  new messages will be stored in the log while we are flushing it
         declare
            Count     : constant Natural := Natural (GL.Debug.Logs.Logged_Messages);
            Remaining :          Natural := Count;
         begin
            if Count > 0 then
               Log_Debug_Message (Application, Other, Notification, 0,
                 "Flushing" & Count'Image & " messages in the debug log:");

               --  Use a loop because GL may fetch less messages than stored in the log
               while Remaining > 0 loop
                  declare
                     Messages : constant GL.Debug.Logs.Message_Array := GL.Debug.Logs.Message_Log;
                  begin
                     for M of Messages loop
                        Log_Debug_Message (M.From, M.Kind, M.Level, M.ID, M.Message.Element);
                     end loop;
                     Remaining := Remaining - Messages'Length;
                  end;
               end loop;

               Log_Debug_Message (Application, Other, Notification, 0, "End of messages in log");
            end if;
         end;

         GL.Toggles.Set (GL.Toggles.Debug_Output_Synchronous,
           (if Raise_API_Error then GL.Toggles.Enabled else GL.Toggles.Disabled));
      else
         GL.Toggles.Disable (GL.Toggles.Debug_Output);
         GL.Debug.Disable_Message_Callback;
      end if;
   end Set_Log_Messages;

end Orka.Debug;

orka: Make flushing log in procedure Set_Log_Messages more robust

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  util-system-os -- Windows system operations
--  Copyright (C) 2011, 2012, 2015, 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 Ada.Unchecked_Deallocation;
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;
with Util.Systems.Constants;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   function Get_Last_Error return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   function Errno return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD
     with Import => True, Convention => Stdcall, Link_Name => "WaitForSingleObject";

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Interfaces.C.int := 0;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := -10;
   STD_OUTPUT_HANDLE : constant DWORD := -11;
   STD_ERROR_HANDLE  : constant DWORD := -12;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   function Get_Std_Handle (Kind : in DWORD) return File_Type
     with Import => True, Convention => Stdcall, Link_Name => "GetStdHandle";

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function STDOUT_FILENO return File_Type
     is (Get_Std_Handle (STD_OUTPUT_HANDLE));

   function STDERR_FILENO return File_Type
     is (Get_Std_Handle (STD_ERROR_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CloseHandle";

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "DuplicateHandle";

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL
   with Import => True, Convention => Stdcall, Link_Name => "ReadFile";

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "WriteFile";

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CreatePipe";

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type FileTime is record
      dwLowDateTime  : DWORD;
      dwHighDateTime : DWORD;
   end record;
   type LPFILETIME is access all FileTime;

   function To_Time (Time : in FileTime) return Util.Systems.Types.Time_Type;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "GetCurrentProcess";

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetExitCodeProcess";

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handles    : in BOOL;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access)
                            return Integer
     with Import => True, Convention => Stdcall, Link_Name => "CreateProcessW";

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "TerminateProcess";

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_stat64";

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t;

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "CreateFileW";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type;

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer;

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer;

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_chmod";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => Stdcall, Link_Name => "strerror";

   function Sys_GetHandleInformation (Fd : in HANDLE; Flags : access DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetHandleInformation";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   function To_WSTR (Value : in String) return Wchar_Ptr;

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Interfaces.C.wchar_array,
                                      Name   => Wchar_Ptr);

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

-----------------------------------------------------------------------
--  util-system-os -- Windows system operations
--  Copyright (C) 2011, 2012, 2015, 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.Unchecked_Deallocation;
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;
with Util.Systems.Constants;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   function Get_Last_Error return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   function Errno return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD
     with Import => True, Convention => Stdcall, Link_Name => "WaitForSingleObject";

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Interfaces.C.int := 0;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := 16#fffffff6#;
   STD_OUTPUT_HANDLE : constant DWORD := 16#fffffff5#;
   STD_ERROR_HANDLE  : constant DWORD := 16#fffffff4#;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   function Get_Std_Handle (Kind : in DWORD) return File_Type
     with Import => True, Convention => Stdcall, Link_Name => "GetStdHandle";

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function STDOUT_FILENO return File_Type
     is (Get_Std_Handle (STD_OUTPUT_HANDLE));

   function STDERR_FILENO return File_Type
     is (Get_Std_Handle (STD_ERROR_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CloseHandle";

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "DuplicateHandle";

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL
   with Import => True, Convention => Stdcall, Link_Name => "ReadFile";

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "WriteFile";

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CreatePipe";

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type FileTime is record
      dwLowDateTime  : DWORD;
      dwHighDateTime : DWORD;
   end record;
   type LPFILETIME is access all FileTime;

   function To_Time (Time : in FileTime) return Util.Systems.Types.Time_Type;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "GetCurrentProcess";

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetExitCodeProcess";

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handles    : in BOOL;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access)
                            return Integer
     with Import => True, Convention => Stdcall, Link_Name => "CreateProcessW";

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "TerminateProcess";

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_stat64";

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t;

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "CreateFileW";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type;

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer;

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer;

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_chmod";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => Stdcall, Link_Name => "strerror";

   function Sys_GetHandleInformation (Fd : in HANDLE; Flags : access DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetHandleInformation";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   function To_WSTR (Value : in String) return Wchar_Ptr;

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Interfaces.C.wchar_array,
                                      Name   => Wchar_Ptr);

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

Fix compilation warnings with GNAT 2021

Fix compilation warnings with GNAT 2021


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

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
package body ASF.Lifecycles.Response is

   use Ada.Exceptions;
   use ASF.Applications;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Response");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      Controller.View_Handler := App.Get_View_Handler;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View    : constant Components.Root.UIViewRoot := Context.Get_View_Root;
   begin
      if Components.Root.Get_Root (View) = null then
         Log.Warn ("Page not found: {0}", Context.Get_View_Name);
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
      else
         Controller.View_Handler.Render_View (Context, View);
      end if;

   exception
      when E : others =>
         Log.Error ("Error when displaying view {0}: {1}: {2}", "?",
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Response;

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

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
package body ASF.Lifecycles.Response is

   use Ada.Exceptions;
   use ASF.Applications;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Response");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Controller.View_Handler := Views;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View    : constant Components.Root.UIViewRoot := Context.Get_View_Root;
   begin
      if Components.Root.Get_Root (View) = null then
         Log.Warn ("Page not found: {0}", Context.Get_View_Name);
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
      else
         Controller.View_Handler.Render_View (Context, View);
      end if;

   exception
      when E : others =>
         Log.Error ("Error when displaying view {0}: {1}: {2}", "?",
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Response;

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


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

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_EVent_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

   end Event_Collector;

end MAT.Events.Targets;

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

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_Event_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

      --  ------------------------------
      --  Get the start and finish time for the events that have been received.
      --  ------------------------------
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time) is
         First : constant Event_Block_Access := Events.First_Element;
         Last  : constant Event_Block_Access := Events.Last_Element;
      begin
         Start  := First.Events (First.Events'First).Time;
         Finish := Last.Events (Last.Count).Time;
      end Get_Time_Range;

   end Event_Collector;

end MAT.Events.Targets;

Implement the Get_Time_Range protected procedure


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

with MAT.Memory.Readers;
package body MAT.Memory.Targets is

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      Memory.Frames := Frames.Create_Root;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in Target_Memory;
                               Sizes  : in out Size_Info_Map) is
      Iter : Allocation_Cursor := Memory.Memory_Slots.First;

      procedure Update_Count (Size : in MAT.Types.Target_Size;
                              Info : in out Size_Info_Type) is
      begin
         Info.Count := Info.Count + 1;
      end Update_Count;

      procedure Collect (Addr : in MAT.Types.Target_Addr;
                         Slot : in Allocation) is
         Pos : Size_Info_Cursor := Sizes.Find (Slot.Size);
      begin
         if Size_Info_Maps.Has_Element (Pos) then
            Sizes.Update_Element (Pos, Update_Count'Access);
         else
            declare
               Info : Size_Info_Type;
            begin
               Info.Count := 1;
               Sizes.Insert (Slot.Size, Info);
            end;
         end if;
      end Collect;

   begin
      while Allocation_Maps.Has_Element (Iter) loop
         Allocation_Maps.Query_Element (Iter, Collect'Access);
         Allocation_Maps.Next (Iter);
      end loop;
   end Size_Information;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Slot.Size);
         Item : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Item := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Item.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

   end Memory_Allocator;

end MAT.Memory.Targets;

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

with MAT.Memory.Readers;
package body MAT.Memory.Targets is

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      Memory.Frames := Frames.Create_Root;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in Target_Memory;
                               Sizes  : in out Size_Info_Map) is
      Iter : Allocation_Cursor := Memory.Memory_Slots.First;

      procedure Update_Count (Size : in MAT.Types.Target_Size;
                              Info : in out Size_Info_Type) is
      begin
         Info.Count := Info.Count + 1;
      end Update_Count;

      procedure Collect (Addr : in MAT.Types.Target_Addr;
                         Slot : in Allocation) is
         Pos : Size_Info_Cursor := Sizes.Find (Slot.Size);
      begin
         if Size_Info_Maps.Has_Element (Pos) then
            Sizes.Update_Element (Pos, Update_Count'Access);
         else
            declare
               Info : Size_Info_Type;
            begin
               Info.Count := 1;
               Sizes.Insert (Slot.Size, Info);
            end;
         end if;
      end Collect;

   begin
      while Allocation_Maps.Has_Element (Iter) loop
         Allocation_Maps.Query_Element (Iter, Collect'Access);
         Allocation_Maps.Next (Iter);
      end loop;
   end Size_Information;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         Old_Slot : Allocation;
         Pos      : Allocation_Cursor;

         procedure Update_Size (Key : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

      begin
         if Old_Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
         else
            Used_Slots.Insert (Addr, Slot);
         end if;
         Remove_Free (Addr, Slot.Size);
      end Probe_Realloc;

   end Memory_Allocator;

end MAT.Memory.Targets;

Implement protected operation Probe_Realloc


-----------------------------------------------------------------------
--  util-beans-objects-datasets-tests -- Unit tests for dataset beans
--  Copyright (C) 2013, 2015, 2017, 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 Util.Test_Caller;

package body Util.Beans.Objects.Datasets.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Datasets",
                       Test_Fill_Dataset'Access);
   end Add_Tests;

   --  Test the creation, initialization and retrieval of dataset content.
   procedure Test_Fill_Dataset (T : in out Test) is
      procedure Fill (Row : in out Object_Array);

      Set : Dataset;

      procedure Fill (Row : in out Object_Array) is
      begin
         Row (Row'First)     := To_Object (String '("john"));
         Row (Row'First + 1) := To_Object (String '("jj@gmail.com"));
         Row (Row'First + 2) := To_Object (Set.Get_Count);
      end Fill;

   begin
      Set.Add_Column ("name");
      Set.Add_Column ("email");
      Set.Add_Column ("age");

      for I in 1 .. 100 loop
         Set.Append (Fill'Access);
      end loop;
      Util.Tests.Assert_Equals (T, 100, Set.Get_Count, "Invalid number of rows");

      for I in 1 .. 100 loop
         Set.Set_Row_Index (I);
         declare
            R : constant Object := Set.Get_Row;
         begin
            T.Assert (not Is_Null (R), "Row is null");
            Util.Tests.Assert_Equals (T, "john", To_String (Get_Value (R, "name")),
                                      "Invalid 'name' attribute");
            Util.Tests.Assert_Equals (T, I, To_Integer (Get_Value (R, "age")),
                                      "Invalid 'age' attribute");
         end;
      end loop;
   end Test_Fill_Dataset;

end Util.Beans.Objects.Datasets.Tests;

-----------------------------------------------------------------------
--  util-beans-objects-datasets-tests -- Unit tests for dataset beans
--  Copyright (C) 2013, 2015, 2017, 2021, 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 Util.Test_Caller;
with Util.Beans.Objects.Iterators;

package body Util.Beans.Objects.Datasets.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Datasets",
                       Test_Fill_Dataset'Access);
   end Add_Tests;

   --  Test the creation, initialization and retrieval of dataset content.
   procedure Test_Fill_Dataset (T : in out Test) is
      procedure Fill (Row : in out Object_Array);

      Set : aliased Dataset;

      procedure Fill (Row : in out Object_Array) is
      begin
         Row (Row'First)     := To_Object (String '("john"));
         Row (Row'First + 1) := To_Object (String '("jj@gmail.com"));
         Row (Row'First + 2) := To_Object (Set.Get_Count);
      end Fill;

   begin
      Set.Add_Column ("name");
      Set.Add_Column ("email");
      Set.Add_Column ("age");

      for I in 1 .. 100 loop
         Set.Append (Fill'Access);
      end loop;
      Util.Tests.Assert_Equals (T, 100, Set.Get_Count, "Invalid number of rows");

      for I in 1 .. 100 loop
         Set.Set_Row_Index (I);
         declare
            R : constant Object := Set.Get_Row;
         begin
            T.Assert (not Is_Null (R), "Row is null");
            Util.Tests.Assert_Equals (T, "john", To_String (Get_Value (R, "name")),
                                      "Invalid 'name' attribute");
            Util.Tests.Assert_Equals (T, I, To_Integer (Get_Value (R, "age")),
                                      "Invalid 'age' attribute");
         end;
      end loop;

      declare
         List  : constant Object := To_Object (Set'Unchecked_Access, STATIC);
         Iter  : Iterators.Iterator := Iterators.First (List);
         Count : Natural := 0;
      begin
         while Iterators.Has_Element (Iter) loop
            Count := Count + 1;
            declare
               R : constant Object := Iterators.Element (Iter);
            begin
               T.Assert (not Is_Null (R), "Row is null");
               Util.Tests.Assert_Equals (T, "john", To_String (Get_Value (R, "name")),
                                         "Invalid 'name' attribute");
               Util.Tests.Assert_Equals (T, Count, To_Integer (Get_Value (R, "age")),
                                         "Invalid 'age' attribute");
            end;
            Iterators.Next (Iter);
         end loop;
         Util.Tests.Assert_Equals (T, 100, Count, "Invalid number of rows");
      end;
   end Test_Fill_Dataset;

end Util.Beans.Objects.Datasets.Tests;

Add a test for the iterator on datasets

Add a test for the iterator on datasets