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

with Ada.Unchecked_Deallocation;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;
with Security.Controllers;
with Security.Controllers.Roles;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

end Security.Permissions;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

end Security.Permissions;

Remove unused with clauses

Remove unused with clauses


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

with Wiki.Helpers;
package body Wiki.Streams.Text_IO is

   --  ------------------------------
   --  Open the file and prepare to read the input stream.
   --  ------------------------------
   procedure Open (Stream : in out File_Input_Stream;
                   Path   : in String;
                   Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Open (Stream.File, Ada.Wide_Wide_Text_IO.In_File, Path, Form);
   end Open;

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

   exception
      when Ada.IO_Exceptions.End_Error =>
         Char := Wiki.Helpers.LF;
         Eof  := True;

   end Read;

   --  ------------------------------
   --  Open the file and prepare to write the output stream.
   --  ------------------------------
   procedure Open (Stream : in out File_Output_Stream;
                   Path   : in String;
                   Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Open (Stream.File, Ada.Wide_Wide_Text_IO.Out_File, Path, Form);
   end Open;

   --  ------------------------------
   --  Create the file and prepare to write the output stream.
   --  ------------------------------
   procedure Create (Stream : in out File_Output_Stream;
                     Path   : in String;
                     Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Create (Stream.File, Ada.Wide_Wide_Text_IO.Out_File, Path, Form);
   end Create;

   --  ------------------------------
   --  Write the string to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream  : in out File_Output_Stream;
                    Content : in Wiki.Strings.WString) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Stream.File, Content);
   end Write;

   --  ------------------------------
   --  Write a single character to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out File_Output_Stream;
                    Char   : in Wiki.Strings.WChar) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Stream.File, Char);
   end Write;

end Wiki.Streams.Text_IO;

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

with Wiki.Helpers;
package body Wiki.Streams.Text_IO is

   --  ------------------------------
   --  Open the file and prepare to read the input stream.
   --  ------------------------------
   procedure Open (Stream : in out File_Input_Stream;
                   Path   : in String;
                   Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Open (Stream.File, Ada.Wide_Wide_Text_IO.In_File, Path, Form);
   end Open;

   --  ------------------------------
   --  Close the file.
   --  ------------------------------
   procedure Close (Stream : in out File_Input_Stream) is
   begin
      Ada.Wide_Wide_Text_IO.Close (Stream.File);
   end Close;

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

   exception
      when Ada.IO_Exceptions.End_Error =>
         Char := Wiki.Helpers.LF;
         Eof  := True;

   end Read;

   --  ------------------------------
   --  Open the file and prepare to write the output stream.
   --  ------------------------------
   procedure Open (Stream : in out File_Output_Stream;
                   Path   : in String;
                   Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Open (Stream.File, Ada.Wide_Wide_Text_IO.Out_File, Path, Form);
   end Open;

   --  ------------------------------
   --  Create the file and prepare to write the output stream.
   --  ------------------------------
   procedure Create (Stream : in out File_Output_Stream;
                     Path   : in String;
                     Form   : in String := "") is
   begin
      Ada.Wide_Wide_Text_IO.Create (Stream.File, Ada.Wide_Wide_Text_IO.Out_File, Path, Form);
   end Create;

   --  ------------------------------
   --  Write the string to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream  : in out File_Output_Stream;
                    Content : in Wiki.Strings.WString) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Stream.File, Content);
   end Write;

   --  ------------------------------
   --  Write a single character to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out File_Output_Stream;
                    Char   : in Wiki.Strings.WChar) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Stream.File, Char);
   end Write;

end Wiki.Streams.Text_IO;

Implement the Close procedure to close the opened file


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

--  === OpenID Configuration ==
--  The Open ID provider needs the following configuration parameters:
--
--    openid.realm          The OpenID realm parameter passed in the authentication URL.
--    openid.callback_url   The OpenID return_to parameter.
--
private package Security.Auth.OpenID is

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is new Security.Auth.Manager with private;

   --  Initialize the OpenID authentication realm.  Get the <tt>openid.realm</tt>
   --  and <tt>openid.callback_url</tt> parameters to configure the realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   type Manager is new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
   end record;

end Security.Auth.OpenID;

-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

--  === OpenID Configuration ==
--  The Open ID provider needs the following configuration parameters:
--
--    openid.realm          The OpenID realm parameter passed in the authentication URL.
--    openid.callback_url   The OpenID return_to parameter.
--
private package Security.Auth.OpenID is

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is new Security.Auth.Manager with private;

   --  Initialize the OpenID authentication realm.  Get the <tt>openid.realm</tt>
   --  and <tt>openid.callback_url</tt> parameters to configure the realm.
   overriding
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   type Manager is new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
   end record;

end Security.Auth.OpenID;

Rename Initialize parameter

Rename Initialize parameter


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

with Util.Test_Caller;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Create_Image",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Get_Sizes",
                       Test_Get_Sizes'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Scale",
                       Test_Scale'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

   --  ------------------------------
   --  Test the Get_Sizes operation.
   --  ------------------------------
   procedure Test_Get_Sizes (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      AWA.Images.Modules.Get_Sizes ("default", Width, Height);
      Util.Tests.Assert_Equals (T, 800, Width, "Default width should be 800");
      Util.Tests.Assert_Equals (T, 0, Height, "Default height should be 0");

      AWA.Images.Modules.Get_Sizes ("123x456", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("x56", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 56, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123x", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("original", Width, Height);
      Util.Tests.Assert_Equals (T, Natural'Last, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, Natural'Last, Height, "Invalid height");
   end Test_Get_Sizes;

   --  ------------------------------
   --  Test the Scale operation.
   --  ------------------------------
   procedure Test_Scale (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      Width := 0;
      Height := 0;
      AWA.Images.Modules.Scale (123, 456, Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      Width := 100;
      Height := 0;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 100, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 20, Height, "Invalid height");

      Width := 0;
      Height := 200;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 1000, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 200, Height, "Invalid height");

   end Test_Scale;

end AWA.Images.Modules.Tests;

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

with Util.Test_Caller;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Create_Image",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Get_Sizes",
                       Test_Get_Sizes'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Modules.Scale",
                       Test_Scale'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

   --  ------------------------------
   --  Test the Get_Sizes operation.
   --  ------------------------------
   procedure Test_Get_Sizes (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      AWA.Images.Modules.Get_Sizes ("default", Width, Height);
      Util.Tests.Assert_Equals (T, 800, Width, "Default width should be 800");
      Util.Tests.Assert_Equals (T, 0, Height, "Default height should be 0");

      AWA.Images.Modules.Get_Sizes ("123x456", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("x56", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 56, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123x", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("original", Width, Height);
      Util.Tests.Assert_Equals (T, Natural'Last, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, Natural'Last, Height, "Invalid height");
   end Test_Get_Sizes;

   --  ------------------------------
   --  Test the Scale operation.
   --  ------------------------------
   procedure Test_Scale (T : in out Test) is
      Width  : Natural;
      Height : Natural;
   begin
      Width := 0;
      Height := 0;
      AWA.Images.Modules.Scale (123, 456, Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      Width := 100;
      Height := 0;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 100, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 20, Height, "Invalid height");

      Width := 0;
      Height := 200;
      AWA.Images.Modules.Scale (10000, 2000, Width, Height);
      Util.Tests.Assert_Equals (T, 1000, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 200, Height, "Invalid height");

   end Test_Scale;

end AWA.Images.Modules.Tests;

Fix the test for Get_Sizes

Fix the test for Get_Sizes


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

package body Util.Encoders.Base16 is

   package body Encoding is

      type Code is mod 2**32;

      function To_Output_Char (Ch : Input_Char) return Code;

      type Conv_Table is array (0 .. 15) of Output_Char;

      Conversion : constant Conv_Table :=
        (0 => Output_Char'Val (Character'Pos ('0')),
         1 => Output_Char'Val (Character'Pos ('1')),
         2 => Output_Char'Val (Character'Pos ('2')),
         3 => Output_Char'Val (Character'Pos ('3')),
         4 => Output_Char'Val (Character'Pos ('4')),
         5 => Output_Char'Val (Character'Pos ('5')),
         6 => Output_Char'Val (Character'Pos ('6')),
         7 => Output_Char'Val (Character'Pos ('7')),
         8 => Output_Char'Val (Character'Pos ('8')),
         9 => Output_Char'Val (Character'Pos ('9')),
         10 => Output_Char'Val (Character'Pos ('A')),
         11 => Output_Char'Val (Character'Pos ('B')),
         12 => Output_Char'Val (Character'Pos ('C')),
         13 => Output_Char'Val (Character'Pos ('D')),
         14 => Output_Char'Val (Character'Pos ('E')),
         15 => Output_Char'Val (Character'Pos ('F')));

      --  Encode the input stream in hexadecimal and write the result
      --  in the output stream
      procedure Encode (From    : in Input;
                        Into    : in out Output;
                        Last    : out Output_Index;
                        Encoded : out Index) is

         N   : constant Output_Index := (Input_Char'Size / 8) * 2;
         Pos : Output_Index := Into'First;
      begin
         for I in From'Range loop
            if Pos + N > Into'Last + 1 then
               Last    := Pos - 1;
               Encoded := I - 1;
               return;
            end if;
            declare
               Value : Code := Input_Char'Pos (From (I));
               P     : Code;
            begin
               Pos := Pos + N;
               for J in 1 .. N / 2 loop
                  P := Value;
                  Value := Value / 16;
                  Into (Pos - J) := Conversion (Natural (P and 16#0F#));

                  P := Value;
                  Into (Pos - J - 1) := Conversion (Natural (P and 16#0F#));
                  Value := Value / 16;
               end loop;
            end;
         end loop;
         Last    := Pos - 1;
         Encoded := From'Last;
      end Encode;

      function To_Output_Char (Ch : Input_Char) return Code is
         C : constant Code := Input_Char'Pos (Ch);
      begin
         if C >= Character'Pos ('a') and C <= Character'Pos ('f') then
            return C - Character'Pos ('a') + 10;

         elsif C >= Character'Pos ('A') and C <= Character'Pos ('F') then
            return C - Character'Pos ('A') + 10;

         elsif C >= Character'Pos ('0') and C <= Character'Pos ('9') then
            return C - Character'Pos ('0');

         else
            raise Encoding_Error with "Invalid character: " & Character'Val (C);
         end if;
      end To_Output_Char;

      procedure Decode (From    : in Input;
                        Into    : in out Output;
                        Last    : out Output_Index;
                        Encoded : out Index) is
         First : Boolean := True;
         Pos   : Output_Index := Into'First;
         Value : Code;
      begin
         if Into'Length < From'Length / 2 then
            Encoded := Into'Length * 2;
         elsif From'Last mod 2 /= 0 then
            Encoded := From'Last - 1;
         else
            Encoded := From'Last;
         end if;
         if Encoded < From'First then
            raise Encoding_Error with "Hexadecimal stream is too short";
         end if;
         for I in From'First .. Encoded loop
            if First then
               Value := To_Output_Char (From (I));
               First := False;
            else
               Value := Value * 16 + To_Output_Char (From (I));
               Into (Pos) := Output_Char'Val (Value);
               Pos := Pos + 1;
               First := True;
            end if;
         end loop;
         Last := Pos - 1;
      end Decode;

   end Encoding;

   package Encoding_Stream is new Encoding (Output => Ada.Streams.Stream_Element_Array,
                                            Index  => Ada.Streams.Stream_Element_Offset,
                                            Output_Index  => Ada.Streams.Stream_Element_Offset,
                                            Input_Char   => Ada.Streams.Stream_Element,
                                            Output_Char   => Ada.Streams.Stream_Element,
                                            Input  => Ada.Streams.Stream_Element_Array);

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base16 (hexadecimal) output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      pragma Unreferenced (E);
   begin
      Encoding_Stream.Encode (Data, Into, Last, Encoded);
   end Transform;

   --  ------------------------------
   --  Decodes the base16 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      pragma Unreferenced (E);
   begin
      Encoding_Stream.Decode (Data, Into, Last, Encoded);
   end Transform;

end Util.Encoders.Base16;

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

package body Util.Encoders.Base16 is

   package body Encoding is

      type Code is mod 2**32;

      function To_Output_Char (Ch : Input_Char) return Code;

      type Conv_Table is array (0 .. 15) of Output_Char;

      Conversion : constant Conv_Table :=
        (0 => Output_Char'Val (Character'Pos ('0')),
         1 => Output_Char'Val (Character'Pos ('1')),
         2 => Output_Char'Val (Character'Pos ('2')),
         3 => Output_Char'Val (Character'Pos ('3')),
         4 => Output_Char'Val (Character'Pos ('4')),
         5 => Output_Char'Val (Character'Pos ('5')),
         6 => Output_Char'Val (Character'Pos ('6')),
         7 => Output_Char'Val (Character'Pos ('7')),
         8 => Output_Char'Val (Character'Pos ('8')),
         9 => Output_Char'Val (Character'Pos ('9')),
         10 => Output_Char'Val (Character'Pos ('A')),
         11 => Output_Char'Val (Character'Pos ('B')),
         12 => Output_Char'Val (Character'Pos ('C')),
         13 => Output_Char'Val (Character'Pos ('D')),
         14 => Output_Char'Val (Character'Pos ('E')),
         15 => Output_Char'Val (Character'Pos ('F')));

      --  Encode the input stream in hexadecimal and write the result
      --  in the output stream
      procedure Encode (From    : in Input;
                        Into    : in out Output;
                        Last    : out Output_Index;
                        Encoded : out Index) is

         N   : constant Output_Index := (Input_Char'Size / 8) * 2;
         Pos : Output_Index := Into'First;
      begin
         for I in From'Range loop
            if Pos + N > Into'Last + 1 then
               Last    := Pos - 1;
               Encoded := I - 1;
               return;
            end if;
            declare
               Value : Code := Input_Char'Pos (From (I));
               P     : Code;
            begin
               Pos := Pos + N;
               for J in 1 .. N / 2 loop
                  P := Value;
                  Value := Value / 16;
                  Into (Pos - J) := Conversion (Natural (P and 16#0F#));

                  P := Value;
                  Into (Pos - J - 1) := Conversion (Natural (P and 16#0F#));
                  Value := Value / 16;
               end loop;
            end;
         end loop;
         Last    := Pos - 1;
         Encoded := From'Last;
      end Encode;

      function To_Output_Char (Ch : Input_Char) return Code is
         C : constant Code := Input_Char'Pos (Ch);
      begin
         if C >= Character'Pos ('a') and C <= Character'Pos ('f') then
            return C - Character'Pos ('a') + 10;

         elsif C >= Character'Pos ('A') and C <= Character'Pos ('F') then
            return C - Character'Pos ('A') + 10;

         elsif C >= Character'Pos ('0') and C <= Character'Pos ('9') then
            return C - Character'Pos ('0');

         else
            raise Encoding_Error with "Invalid character: " & Character'Val (C);
         end if;
      end To_Output_Char;

      procedure Decode (From    : in Input;
                        Into    : in out Output;
                        Last    : out Output_Index;
                        Encoded : out Index) is
         First : Boolean := True;
         Pos   : Output_Index := Into'First;
         Value : Code;
      begin
         if Into'Length < From'Length / 2 then
            Encoded := Into'Length * 2;
         elsif From'Last mod 2 /= 0 then
            Encoded := From'Last - 1;
         else
            Encoded := From'Last;
         end if;
         if Encoded < From'First then
            raise Encoding_Error with "Hexadecimal stream is too short";
         end if;
         for I in From'First .. Encoded loop
            if First then
               Value := To_Output_Char (From (I));
               First := False;
            else
               Value := Value * 16 + To_Output_Char (From (I));
               Into (Pos) := Output_Char'Val (Value);
               Pos := Pos + 1;
               First := True;
            end if;
         end loop;
         Last := Pos - 1;
      end Decode;

   end Encoding;

   package Encoding_Stream is new Encoding (Output => Ada.Streams.Stream_Element_Array,
                                            Index  => Ada.Streams.Stream_Element_Offset,
                                            Output_Index  => Ada.Streams.Stream_Element_Offset,
                                            Input_Char   => Ada.Streams.Stream_Element,
                                            Output_Char   => Ada.Streams.Stream_Element,
                                            Input  => Ada.Streams.Stream_Element_Array);

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base16 (hexadecimal) output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      pragma Unreferenced (E);
   begin
      Encoding_Stream.Encode (Data, Into, Last, Encoded);
   end Transform;

   --  ------------------------------
   --  Decodes the base16 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      pragma Unreferenced (E);
   begin
      Encoding_Stream.Decode (Data, Into, Last, Encoded);
   end Transform;

end Util.Encoders.Base16;

Change the Transformer interface to accept in out parameter for the Transformer


-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  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 System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

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

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : constant Object_Pointer := To_Pointer (Buffer.Current
                                                    + Storage_Offset (1));
      Low  : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 4;
      Buffer.Current := Buffer.Current + Storage_Offset (4);
      if Buffer.Current >= Buffer.Last then
         Buffer.Current := Buffer.Start;
      end if;
      return P.all;
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : constant MAT.Types.Uint64 := MAT.Types.Uint64 (Get_Uint32 (Buffer));
   begin
      return Val + MAT.Types.Uint64 (Get_Uint32 (Buffer)) * 2**32;
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Buffer_Ptr) return String is
      Len    : constant MAT.Types.Uint8 := Get_Uint8 (Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  Ipc -- Ipc channel between profiler tool and application          --
--  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 Interfaces;
with System; use System;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
with Util.Log.Loggers;
with Interfaces; use Interfaces;
package body MAT.Readers.Marshaller is

   use System.Storage_Elements;

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

   package Uint8_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint8);

   package Uint32_Access is new System.Address_To_Access_Conversions (MAT.Types.Uint32);

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32 is
      use Uint32_Access;

      P : constant Object_Pointer := To_Pointer (Buf);
   begin
      return P.all;
   end Get_Raw_Uint32;

   --  ------------------------------
   --  Get an 8-bit value from the buffer.
   --  ------------------------------
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8 is
      use Uint8_Access;

      P : constant Object_Pointer := To_Pointer (Buffer.Current);
   begin
      if Buffer.Size = 0 then
         Log.Error ("Not enough data to get a uint8");
         raise Buffer_Underflow_Error;
      end if;
      Buffer.Size := Buffer.Size - 1;
      Buffer.Current := Buffer.Current + Storage_Offset (1);
      return P.all;
   end Get_Uint8;

   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16 is
      use Uint8_Access;

      High : Object_Pointer;
      Low  : Object_Pointer;
   begin
      if Buffer.Size <= 1 then
         Log.Error ("Not enough data to get a uint16");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := To_Pointer (Buffer.Current);
         High := To_Pointer (Buffer.Current + Storage_Offset (1));
      else
         High := To_Pointer (Buffer.Current);
         Low  := To_Pointer (Buffer.Current + Storage_Offset (1));
      end if;
      Buffer.Size := Buffer.Size - 2;
      Buffer.Current := Buffer.Current + Storage_Offset (2);
      return MAT.Types.Uint16 (High.all) * 256 + MAT.Types.Uint16 (Low.all);
   end Get_Uint16;

   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32 is
      use Uint32_Access;

      Low, High : MAT.Types.Uint16;
   begin
      if Buffer.Size < 4 then
         Log.Error ("Not enough data to get a uint32");
         raise Buffer_Underflow_Error;
      end if;
      if Buffer.Endian = LITTLE_ENDIAN then
         Low  := Get_Uint16 (Buffer);
         High := Get_Uint16 (Buffer);
      else
         High := Get_Uint16 (Buffer);
         Low  := Get_Uint16 (Buffer);
      end if;
      return Interfaces.Shift_Left (MAT.Types.Uint32 (High), 16) + MAT.Types.Uint32 (Low);
   end Get_Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64 is
      Val : constant MAT.Types.Uint64 := MAT.Types.Uint64 (Get_Uint32 (Buffer));
   begin
      return Val + MAT.Types.Uint64 (Get_Uint32 (Buffer)) * 2**32;
   end Get_Uint64;

   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type is
   begin
      case Kind is
         when MAT.Events.T_UINT8 =>
            return Target_Type (Get_Uint8 (Msg));

         when MAT.Events.T_UINT16 =>
            return Target_Type (Get_Uint16 (Msg));

         when MAT.Events.T_UINT32 =>
            return Target_Type (Get_Uint32 (Msg));

         when MAT.Events.T_UINT64 =>
            return Target_Type (Get_Uint64 (Msg));

         when others =>
            Log.Error ("Invalid attribute type {0}",
                       MAT.Events.Attribute_Type'Image (Kind));
            return 0;
      end case;
   end Get_Target_Value;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Buffer : in Buffer_Ptr) return String is
      Len    : constant MAT.Types.Uint8 := Get_Uint8 (Buffer);
      Result : String (1 .. Natural (Len));
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Get_Uint8 (Buffer));
      end loop;
      return Result;
   end Get_String;

   --  ------------------------------
   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   --  ------------------------------
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Get_String (Msg));
   end Get_String;

   --  ------------------------------
   --  Skip the given number of bytes from the message.
   --  ------------------------------
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural) is
   begin
      Buffer.Size := Buffer.Size - Size;
      Buffer.Current := Buffer.Current + Storage_Offset (Size);
   end Skip;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Size);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr is
         function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32 is
      function Get_Value is new Get_Target_Value (MAT.Types.Target_Addr);
   begin
      return Get_Value (Msg, Kind);
   end Get_Target_Uint32;

end MAT.Readers.Marshaller;

Document Get_Uint8 and fix Get_Uint16 to support big/little endian


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

with Util.Test_Caller;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Votes.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Votes.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Votes.Modules.Vote_For",
                       Test_Vote_Up'Access);
      Caller.Add_Test (Suite, "Test AWA.Votes.Modules.Vote_For (Undo)",
                       Test_Vote_Undo'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Vote_Up (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      declare
         Vote_Manager : constant Vote_Module_Access := Get_Vote_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         Total        : Integer;
      begin
         T.Assert (Vote_Manager /= null, "There is no vote module");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 1, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 2, Total);
         T.Assert (Total > 0, "Invalid total");
      end;
   end Test_Vote_Up;

   --  ------------------------------
   --  Test vote.
   --  ------------------------------
   procedure Test_Vote_Undo (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-vote@test.com");

      declare
         Vote_Manager : constant Vote_Module_Access := Get_Vote_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         Total        : Integer;
      begin
         T.Assert (Vote_Manager /= null, "There is no vote module");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 1, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 2, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 0, Total);
         T.Assert (Total >= 0, "Invalid total");
      end;
   end Test_Vote_Undo;

end AWA.Votes.Modules.Tests;

-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for storage service
--  Copyright (C) 2013, 2018, 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 Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
package body AWA.Votes.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Votes.Modules.Vote_For",
                       Test_Vote_Up'Access);
      Caller.Add_Test (Suite, "Test AWA.Votes.Modules.Vote_For (Undo)",
                       Test_Vote_Undo'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Vote_Up (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      declare
         Vote_Manager : constant Vote_Module_Access := Get_Vote_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         Total        : Integer;
      begin
         T.Assert (Vote_Manager /= null, "There is no vote module");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 1, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 2, Total);
         T.Assert (Total > 0, "Invalid total");
      end;
   end Test_Vote_Up;

   --  ------------------------------
   --  Test vote.
   --  ------------------------------
   procedure Test_Vote_Undo (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-vote@test.com");

      declare
         Vote_Manager : constant Vote_Module_Access := Get_Vote_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         Total        : Integer;
      begin
         T.Assert (Vote_Manager /= null, "There is no vote module");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 1, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 2, Total);
         T.Assert (Total > 0, "Invalid total");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 0, Total);
         T.Assert (Total >= 0, "Invalid total");
      end;
   end Test_Vote_Undo;

end AWA.Votes.Modules.Tests;

Fix compilation warning with GCC 12: remove unused with clause for an ancestor


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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_ID,
                       F_OLD_ADDR,
                       F_TIME,
                       F_EVENT,
                       F_FRAME_ID,
                       F_FRAME_ADDR);

   type Notice_Type is (N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

private

   type Field_Size_Array is array (Field_Type) of Natural;

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

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

end MAT.Consoles;

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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_ID,
                       F_OLD_ADDR,
                       F_TIME,
                       F_EVENT,
                       F_FRAME_ID,
                       F_FRAME_ADDR);

   type Notice_Type is (N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

private

   type Field_Size_Array is array (Field_Type) of Natural;

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

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

end MAT.Consoles;

Add a Justify parameter to the Print_Field procedure